{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE EmptyCase #-}

#if __GLASGOW_HASKELL__ >= 811 && __GLASGOW_HASKELL__ < 901
-- For the Option instance (https://gitlab.haskell.org/ghc/ghc/issues/15028)
{-# OPTIONS_GHC -Wno-deprecations #-}
#endif

#define BYTEARRAY_IN_BASE (__GLASGOW_HASKELL__ >= 903)
-- At the moment of writing GHC source tree has not yet bumped `base` version,
-- so using __GLASGOW_HASKELL__ as a proxy instead of MIN_VERSION_base(4,17,0).

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.DeepSeq
-- Copyright   :  (c) The University of Glasgow 2001-2009
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  stable
-- Portability :  portable
--
-- This module provides overloaded functions, such as 'deepseq' and
-- 'rnf', for fully evaluating data structures (that is, evaluating to
-- \"Normal Form\").
--
-- A typical use is to prevent resource leaks in lazy IO programs, by
-- forcing all characters from a file to be read. For example:
--
-- > import System.IO
-- > import Control.DeepSeq
-- > import Control.Exception (evaluate)
-- >
-- > readFile' :: FilePath -> IO String
-- > readFile' fn = do
-- >     h <- openFile fn ReadMode
-- >     s <- hGetContents h
-- >     evaluate (rnf s)
-- >     hClose h
-- >     return s
--
-- __Note__: The example above should rather be written in terms of
-- 'Control.Exception.bracket' to ensure releasing file-descriptors in
-- a timely matter (see the description of 'force' for an example).
--
-- 'deepseq' differs from 'seq' as it traverses data structures deeply,
-- for example, 'seq' will evaluate only to the first constructor in
-- the list:
--
-- > > [1,2,undefined] `seq` 3
-- > 3
--
-- While 'deepseq' will force evaluation of all the list elements:
--
-- > > [1,2,undefined] `deepseq` 3
-- > *** Exception: Prelude.undefined
--
-- Another common use is to ensure any exceptions hidden within lazy
-- fields of a data structure do not leak outside the scope of the
-- exception handler, or to force evaluation of a data structure in one
-- thread, before passing to another thread (preventing work moving to
-- the wrong threads).
--
-- @since 1.1.0.0
module Control.DeepSeq (
     -- * 'NFData' class
     NFData(rnf),
     -- * Helper functions
     deepseq,
     force,
     ($!!),
     (<$!!>),
     rwhnf,

     -- * Liftings of the 'NFData' class
     -- ** For unary constructors
     NFData1(liftRnf), rnf1,
     -- ** For binary constructors
     NFData2(liftRnf2), rnf2,
  ) where

import Control.Applicative
import Control.Concurrent ( ThreadId, MVar )
import Control.Exception ( MaskingState(..) )
import Data.IORef
import Data.STRef
import Data.Int
import Data.Word
import Data.Ratio
import Data.Complex
import Data.Array
import Data.Fixed
import Data.Version
import Data.Monoid as Mon
import Data.Typeable ( TypeRep, TyCon )
import Data.Unique ( Unique )
import Foreign.Ptr
import Foreign.C.Types
import System.Exit ( ExitCode(..) )
import System.Mem.StableName ( StableName )
import Data.Ord ( Down(Down) )
import Data.Proxy ( Proxy(Proxy) )

#if MIN_VERSION_base(4,10,0)
import Data.Type.Equality ( (:~:), (:~~:) )
#else
import Data.Type.Equality ( (:~:) )
#endif

import Data.Functor.Identity ( Identity(..) )
import Data.Typeable ( rnfTypeRep, rnfTyCon )
import Data.Void ( Void, absurd )
import Numeric.Natural ( Natural )

import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Semigroup as Semi

import GHC.Stack.Types ( CallStack(..), SrcLoc(..) )
import Data.Functor.Compose
import qualified Data.Functor.Sum as Functor
import qualified Data.Functor.Product as Functor

import GHC.Fingerprint.Type ( Fingerprint(..) )
import GHC.Generics

#ifdef MIN_VERSION_ghc_prim
#if MIN_VERSION_ghc_prim(0,7,0)
import GHC.Tuple (Solo (..))
#endif
#endif

#if BYTEARRAY_IN_BASE
import Data.Array.Byte (ByteArray(..))
#endif

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

instance GNFData arity V1 where
  grnf _ x = case x of {}

data Zero
data One

data RnfArgs arity a where
  RnfArgs0 :: RnfArgs Zero a
  RnfArgs1  :: (a -> ()) -> RnfArgs One a

instance GNFData arity U1 where
  grnf _ U1 = ()

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

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

instance GNFData arity (URec a) where
  grnf _ = rwhnf -- Every URec data instance consists of a single data
                 -- constructor containing a single strict field, so reducing
                 -- any URec instance to WHNF suffices to reduce it to NF.
  {-# INLINEABLE grnf #-}

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

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

instance GNFData One Par1 where
    grnf (RnfArgs1 r) = r . unPar1

instance NFData1 f => GNFData One (Rec1 f) where
    grnf (RnfArgs1 r) = liftRnf r . unRec1

instance (NFData1 f, GNFData One g) => GNFData One (f :.: g) where
    grnf args = liftRnf (grnf args) . unComp1

infixr 0 $!!
infixr 0 `deepseq`

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

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

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

-- | Deeply strict version of 'Control.Applicative.<$>'.
--
-- @since 1.4.3.0
(<$!!>) :: (Monad m, NFData b) => (a -> b) -> m a -> m b
#if MIN_VERSION_base(4,8,0)
-- Minor optimisation for AMP; this avoids the redundant indirection
-- through 'return' in case GHC isn't smart enough to optimise it away
-- on its own
f <$!!> m = m >>= \x -> pure $!! f x
#else
f <$!!> m = m >>= \x -> return $!! f x
#endif
infixl 4 <$!!>

-- | Reduce to weak head normal form
--
-- Equivalent to @\\x -> 'seq' x ()@.
--
-- Useful for defining 'NFData' for types for which NF=WHNF holds.
--
-- > data T = C1 | C2 | C3
-- > instance NFData T where rnf = rwhnf
--
-- @since 1.4.3.0
rwhnf :: a -> ()
rwhnf = (`seq` ())
{-# INLINE rwhnf #-}

-- Note: the 'rwhnf' is defined point-free to help aggressive inlining

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

    default rnf :: (Generic a, GNFData Zero (Rep a)) => a -> ()
    rnf = grnf RnfArgs0 . from

-- | A class of functors that can be fully evaluated.
--
-- @since 1.4.3.0
class NFData1 f where
    -- | 'liftRnf' should reduce its argument to normal form (that is, fully
    -- evaluate all sub-components), given an argument to reduce @a@ arguments,
    -- and then return '()'.
    --
    -- See 'rnf' for the generic deriving.
    liftRnf :: (a -> ()) -> f a -> ()

    default liftRnf :: (Generic1 f, GNFData One (Rep1 f)) => (a -> ()) -> f a -> ()
    liftRnf r = grnf (RnfArgs1 r) . from1

-- | Lift the standard 'rnf' function through the type constructor.
--
-- @since 1.4.3.0
rnf1 :: (NFData1 f, NFData a) => f a -> ()
rnf1 = liftRnf rnf

-- | A class of bifunctors that can be fully evaluated.
--
-- @since 1.4.3.0
class NFData2 p where
    -- | 'liftRnf2' should reduce its argument to normal form (that
    -- is, fully evaluate all sub-components), given functions to
    -- reduce @a@ and @b@ arguments respectively, and then return '()'.
    --
    -- __Note__: Unlike for the unary 'liftRnf', there is currently no
    -- support for generically deriving 'liftRnf2'.
    liftRnf2 :: (a -> ()) -> (b -> ()) -> p a b -> ()

-- | Lift the standard 'rnf' function through the type constructor.
--
-- @since 1.4.3.0
rnf2 :: (NFData2 p, NFData a, NFData b) => p a b -> ()
rnf2 = liftRnf2 rnf rnf

instance NFData Int      where rnf = rwhnf
instance NFData Word     where rnf = rwhnf
instance NFData Integer  where rnf = rwhnf
instance NFData Float    where rnf = rwhnf
instance NFData Double   where rnf = rwhnf

instance NFData Char     where rnf = rwhnf
instance NFData Bool     where rnf = rwhnf
instance NFData Ordering where rnf = rwhnf
instance NFData ()       where rnf = rwhnf

instance NFData Int8     where rnf = rwhnf
instance NFData Int16    where rnf = rwhnf
instance NFData Int32    where rnf = rwhnf
instance NFData Int64    where rnf = rwhnf

instance NFData Word8    where rnf = rwhnf
instance NFData Word16   where rnf = rwhnf
instance NFData Word32   where rnf = rwhnf
instance NFData Word64   where rnf = rwhnf

-- | @since 1.4.4.0
instance NFData MaskingState where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData (Proxy a) where rnf Proxy = ()
-- |@since 1.4.3.0
instance NFData1 Proxy    where liftRnf _ Proxy = ()

-- | @since 1.4.3.0
instance NFData (a :~: b) where rnf = rwhnf
-- | @since 1.4.3.0
instance NFData1 ((:~:) a) where liftRnf _ = rwhnf
-- | @since 1.4.3.0
instance NFData2 (:~:) where liftRnf2 _ _ = rwhnf

#if MIN_VERSION_base(4,10,0)
-- | @since 1.4.3.0
instance NFData (a :~~: b) where rnf = rwhnf
-- | @since 1.4.3.0
instance NFData1 ((:~~:) a) where liftRnf _ = rwhnf
-- | @since 1.4.3.0
instance NFData2 (:~~:) where liftRnf2 _ _ = rwhnf
#endif

-- |@since 1.4.0.0
instance NFData a => NFData (Identity a) where
    rnf = rnf1

-- |@since 1.4.3.0
instance NFData1 Identity where
    liftRnf r = r . runIdentity

-- | Defined as @'rnf' = 'absurd'@.
--
-- @since 1.4.0.0
instance NFData Void where
    rnf = absurd

-- |@since 1.4.0.0
instance NFData Natural  where rnf = rwhnf

-- |@since 1.3.0.0
instance NFData (Fixed a) where rnf = rwhnf
-- |@since 1.4.3.0
instance NFData1 Fixed where liftRnf _ = rwhnf

-- |This instance is for convenience and consistency with 'seq'.
-- This assumes that WHNF is equivalent to NF for functions.
--
-- @since 1.3.0.0
instance NFData (a -> b) where rnf = rwhnf

--Rational and complex numbers.

-- | Available on @base >=4.9@
--
-- @since 1.4.3.0
instance NFData1 Ratio where
  liftRnf r x = r (numerator x) `seq` r (denominator x)

-- | @since 1.4.3.0
instance (NFData1 f, NFData1 g) => NFData1 (Compose f g) where
  liftRnf r = liftRnf (liftRnf r) . getCompose

-- | @since 1.4.3.0
instance (NFData1 f, NFData1 g, NFData a) => NFData (Compose f g a) where
  rnf = rnf1

-- | @since 1.4.3.0
instance (NFData1 f, NFData1 g) => NFData1 (Functor.Sum f g) where
  liftRnf rnf0 (Functor.InL l) = liftRnf rnf0 l
  liftRnf rnf0 (Functor.InR r) = liftRnf rnf0 r

-- | @since 1.4.3.0
instance (NFData1 f, NFData1 g, NFData a) => NFData (Functor.Sum f g a) where
  rnf = rnf1

-- | @since 1.4.3.0
instance (NFData1 f, NFData1 g) => NFData1 (Functor.Product f g) where
  liftRnf rnf0 (Functor.Pair f g) = liftRnf rnf0 f `seq` liftRnf rnf0 g

-- | @since 1.4.3.0
instance (NFData1 f, NFData1 g, NFData a) => NFData (Functor.Product f g a) where
  rnf = rnf1

instance NFData a => NFData (Ratio a) where
  rnf x = rnf (numerator x, denominator x)

instance (NFData a) => NFData (Complex a) where
  rnf (x:+y) = rnf x `seq`
               rnf y `seq`
               ()

instance NFData a => NFData (Maybe a) where rnf = rnf1
-- |@since 1.4.3.0
instance NFData1 Maybe where
    liftRnf _r Nothing  = ()
    liftRnf  r (Just x) = r x

instance (NFData a, NFData b) => NFData (Either a b) where rnf = rnf1
-- |@since 1.4.3.0
instance (NFData a) => NFData1 (Either a) where liftRnf = liftRnf2 rnf
-- |@since 1.4.3.0
instance NFData2 Either where
    liftRnf2  l _r (Left x)  = l x
    liftRnf2 _l  r (Right y) = r y

-- |@since 1.3.0.0
instance NFData Data.Version.Version where
    rnf (Data.Version.Version branch tags) = rnf branch `seq` rnf tags

instance NFData a => NFData [a] where rnf = rnf1
-- |@since 1.4.3.0
instance NFData1 [] where
    liftRnf r = go
      where
        go [] = ()
        go (x:xs) = r x `seq` go xs

-- |@since 1.4.0.0
instance NFData a => NFData (ZipList a) where rnf = rnf1
-- |@since 1.4.3.0
instance NFData1 ZipList where
    liftRnf r = liftRnf r . getZipList

-- |@since 1.4.0.0
instance NFData a => NFData (Const a b) where
    rnf = rnf . getConst
-- |@since 1.4.3.0
instance NFData a => NFData1 (Const a) where
    liftRnf _ = rnf . getConst
-- |@since 1.4.3.0
instance NFData2 Const where
    liftRnf2 r _ = r . getConst

-- We should use MIN_VERSION array(0,5,1,1) but that's not possible.
-- There isn't an underscore to not break C preprocessor
instance (NFData a, NFData b) => NFData (Array a b) where
    rnf x = rnf (bounds x, Data.Array.elems x)

-- |@since 1.4.3.0
instance (NFData a) => NFData1 (Array a) where
    liftRnf r x = rnf (bounds x) `seq` liftRnf r (Data.Array.elems x)

-- |@since 1.4.3.0
instance NFData2 Array where
    liftRnf2 r r' x = liftRnf2 r r (bounds x) `seq` liftRnf r' (Data.Array.elems x)

-- |@since 1.4.0.0
instance NFData a => NFData (Down a) where rnf = rnf1
-- |@since 1.4.3.0
instance NFData1 Down where
    liftRnf r (Down x) = r x

-- |@since 1.4.0.0
instance NFData a => NFData (Dual a) where rnf = rnf1
-- |@since 1.4.3.0
instance NFData1 Dual where
    liftRnf r (Dual x) = r x

-- |@since 1.4.0.0
instance NFData a => NFData (Mon.First a) where rnf = rnf1
-- |@since 1.4.3.0
instance NFData1 Mon.First  where
    liftRnf r (Mon.First x) = liftRnf r x

-- |@since 1.4.0.0
instance NFData a => NFData (Mon.Last a) where rnf = rnf1
-- |@since 1.4.3.0
instance NFData1 Mon.Last  where
    liftRnf r (Mon.Last  x) = liftRnf r x

-- |@since 1.4.0.0
instance NFData Any where rnf = rnf . getAny

-- |@since 1.4.0.0
instance NFData All where rnf = rnf . getAll

-- |@since 1.4.0.0
instance NFData a => NFData (Sum a) where rnf = rnf1
-- |@since 1.4.3.0
instance NFData1 Sum where
    liftRnf r (Sum x) = r x

-- |@since 1.4.0.0
instance NFData a => NFData (Product a) where rnf = rnf1
-- |@since 1.4.3.0
instance NFData1 Product where
    liftRnf r (Product x) = r x

-- |@since 1.4.0.0
instance NFData (StableName a) where
    rnf = rwhnf -- assumes `data StableName a = StableName (StableName# a)`
-- |@since 1.4.3.0
instance NFData1 StableName where
    liftRnf _ = rwhnf

-- |@since 1.4.0.0
instance NFData ThreadId where
    rnf = rwhnf -- assumes `data ThreadId = ThreadId ThreadId#`

-- |@since 1.4.0.0
instance NFData Unique where
    rnf = rwhnf -- assumes `newtype Unique = Unique Integer`

-- | __NOTE__: Prior to @deepseq-1.4.4.0@ this instance was only defined for @base-4.8.0.0@ and later.
--
-- @since 1.4.0.0
instance NFData TypeRep where
    rnf tyrep = rnfTypeRep tyrep

-- | __NOTE__: Prior to @deepseq-1.4.4.0@ this instance was only defined for @base-4.8.0.0@ and later.
--
-- @since 1.4.0.0
instance NFData TyCon where
    rnf tycon = rnfTyCon tycon

-- | __NOTE__: Only strict in the reference and not the referenced value.
--
-- @since 1.4.2.0
instance NFData (IORef a) where
    rnf = rwhnf
-- |@since 1.4.3.0
instance NFData1 IORef where
    liftRnf _ = rwhnf

-- | __NOTE__: Only strict in the reference and not the referenced value.
--
-- @since 1.4.2.0
instance NFData (STRef s a) where
    rnf = rwhnf
-- |@since 1.4.3.0
instance NFData1 (STRef s) where
    liftRnf _ = rwhnf
-- |@since 1.4.3.0
instance NFData2 STRef where
    liftRnf2 _ _ = rwhnf

-- | __NOTE__: Only strict in the reference and not the referenced value.
--
-- @since 1.4.2.0
instance NFData (MVar a) where
  rnf = rwhnf
-- |@since 1.4.3.0
instance NFData1 MVar where
    liftRnf _ = rwhnf

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

-- |@since 1.4.0.0
instance NFData Fingerprint where
    rnf (Fingerprint _ _) = ()

----------------------------------------------------------------------------
-- Foreign.Ptr

-- |@since 1.4.2.0
instance NFData (Ptr a) where
    rnf = rwhnf
-- |@since 1.4.3.0
instance NFData1 Ptr where
    liftRnf _ = rwhnf

-- |@since 1.4.2.0
instance NFData (FunPtr a) where
    rnf = rwhnf
-- |@since 1.4.3.0
instance NFData1 FunPtr where
    liftRnf _ = rwhnf

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

-- |@since 1.4.0.0
instance NFData CChar where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CSChar where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CUChar where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CShort where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CUShort where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CInt where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CUInt where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CLong where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CULong where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CPtrdiff where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CSize where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CWchar where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CSigAtomic where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CLLong where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CULLong where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CIntPtr where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CUIntPtr where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CIntMax where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CUIntMax where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CClock where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CTime where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CUSeconds where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CSUSeconds where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CFloat where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CDouble where rnf = rwhnf

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

-- |@since 1.4.0.0
instance NFData CFile where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CFpos where rnf = rwhnf

-- |@since 1.4.0.0
instance NFData CJmpBuf where rnf = rwhnf

#if MIN_VERSION_base(4,10,0)
-- | @since 1.4.3.0
instance NFData CBool where rnf = rwhnf
#endif

----------------------------------------------------------------------------
-- System.Exit

-- |@since 1.4.2.0
instance NFData ExitCode where
  rnf (ExitFailure n) = rnf n
  rnf ExitSuccess     = ()

----------------------------------------------------------------------------
-- instances previously provided by semigroups package

-- |@since 1.4.2.0
instance NFData a => NFData (NonEmpty a) where rnf = rnf1
-- |@since 1.4.3.0
instance NFData1 NonEmpty where
  liftRnf r (x :| xs) = r x `seq` liftRnf r xs

-- |@since 1.4.2.0
instance NFData a => NFData (Min a) where rnf = rnf1
-- |@since 1.4.3.0
instance NFData1 Min where
  liftRnf r (Min a) = r a

-- |@since 1.4.2.0
instance NFData a => NFData (Max a) where rnf = rnf1
-- |@since 1.4.3.0
instance NFData1 Max where
  liftRnf r (Max a) = r a

-- |@since 1.4.2.0
instance (NFData a, NFData b) => NFData (Arg a b) where rnf = rnf2
-- |@since 1.4.3.0
instance (NFData a) => NFData1 (Arg a) where liftRnf = liftRnf2 rnf
-- |@since 1.4.3.0
instance NFData2 Arg where
  liftRnf2 r r' (Arg a b) = r a `seq` r' b `seq` ()

-- |@since 1.4.2.0
instance NFData a => NFData (Semi.First a) where rnf = rnf1
-- |@since 1.4.3.0
instance NFData1 Semi.First where
  liftRnf r (Semi.First a) = r a

-- |@since 1.4.2.0
instance NFData a => NFData (Semi.Last a) where rnf = rnf1
-- |@since 1.4.3.0
instance NFData1 Semi.Last where
  liftRnf r (Semi.Last a) = r a

-- |@since 1.4.2.0
instance NFData m => NFData (WrappedMonoid m) where rnf = rnf1
-- |@since 1.4.3.0
instance NFData1 WrappedMonoid where
  liftRnf r (WrapMonoid a) = r a

#if __GLASGOW_HASKELL__ < 901
-- |@since 1.4.2.0
instance NFData a => NFData (Option a) where rnf = rnf1
-- |@since 1.4.3.0
instance NFData1 Option where
  liftRnf r (Option a) = liftRnf r a
#endif

----------------------------------------------------------------------------
-- GHC.Stack

-- |@since 1.4.2.0
instance NFData SrcLoc where
  rnf (SrcLoc a b c d e f g) = rnf a `seq` rnf b `seq` rnf c `seq`
                               rnf d `seq` rnf e `seq` rnf f `seq` rnf g

-- |@since 1.4.2.0
instance NFData CallStack where
  rnf EmptyCallStack = ()
  rnf (PushCallStack a b c) = rnf a `seq` rnf b `seq` rnf c
  rnf (FreezeCallStack a)   = rnf a

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

#ifdef MIN_VERSION_ghc_prim
#if MIN_VERSION_ghc_prim(0,7,0)
-- |@since 1.4.6.0
instance NFData a => NFData (Solo a) where
  rnf (Solo a) = rnf a
-- |@since 1.4.6.0
instance NFData1 Solo where
  liftRnf r (Solo a) = r a
#endif
#endif

instance (NFData a, NFData b) => NFData (a,b) where rnf = rnf2
-- |@since 1.4.3.0
instance (NFData a) => NFData1 ((,) a) where liftRnf = liftRnf2 rnf
-- |@since 1.4.3.0
instance NFData2 (,) where
  liftRnf2 r r' (x,y) = r x `seq` r' y

-- Code below is generated, see generate-nfdata-tuple.hs
instance (NFData a1, NFData a2, NFData a3) =>
         NFData (a1, a2, a3) where rnf = rnf2
-- |@since 1.4.3.0
instance (NFData a1, NFData a2) =>
         NFData1 ((,,) a1 a2) where liftRnf = liftRnf2 rnf
-- |@since 1.4.3.0
instance (NFData a1) =>
         NFData2 ((,,) a1) where
  liftRnf2 r r' (x1,x2,x3) = rnf x1 `seq` r x2 `seq` r' x3

instance (NFData a1, NFData a2, NFData a3, NFData a4) =>
         NFData (a1, a2, a3, a4) where rnf = rnf2
-- |@since 1.4.3.0
instance (NFData a1, NFData a2, NFData a3) =>
         NFData1 ((,,,) a1 a2 a3) where liftRnf = liftRnf2 rnf
-- |@since 1.4.3.0
instance (NFData a1, NFData a2) =>
         NFData2 ((,,,) a1 a2) where
  liftRnf2 r r' (x1,x2,x3,x4) = rnf x1 `seq` rnf x2 `seq` r x3 `seq` r' x4

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5) =>
         NFData (a1, a2, a3, a4, a5) where rnf = rnf2
-- |@since 1.4.3.0
instance (NFData a1, NFData a2, NFData a3, NFData a4) =>
         NFData1 ((,,,,) a1 a2 a3 a4) where liftRnf = liftRnf2 rnf
-- |@since 1.4.3.0
instance (NFData a1, NFData a2, NFData a3) =>
         NFData2 ((,,,,) a1 a2 a3) where
  liftRnf2 r r' (x1,x2,x3,x4,x5) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` r x4 `seq` r' x5

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6) =>
         NFData (a1, a2, a3, a4, a5, a6) where rnf = rnf2
-- |@since 1.4.3.0
instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5) =>
         NFData1 ((,,,,,) a1 a2 a3 a4 a5) where liftRnf = liftRnf2 rnf
-- |@since 1.4.3.0
instance (NFData a1, NFData a2, NFData a3, NFData a4) =>
         NFData2 ((,,,,,) a1 a2 a3 a4) where
  liftRnf2 r r' (x1,x2,x3,x4,x5,x6) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` r x5 `seq` r' x6

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7) =>
         NFData (a1, a2, a3, a4, a5, a6, a7) where rnf = rnf2
-- |@since 1.4.3.0
instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6) =>
         NFData1 ((,,,,,,) a1 a2 a3 a4 a5 a6) where liftRnf = liftRnf2 rnf
-- |@since 1.4.3.0
instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5) =>
         NFData2 ((,,,,,,) a1 a2 a3 a4 a5) where
  liftRnf2 r r' (x1,x2,x3,x4,x5,x6,x7) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` r x6 `seq` r' x7

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8) =>
         NFData (a1, a2, a3, a4, a5, a6, a7, a8) where rnf = rnf2
-- |@since 1.4.3.0
instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7) =>
         NFData1 ((,,,,,,,) a1 a2 a3 a4 a5 a6 a7) where liftRnf = liftRnf2 rnf
-- |@since 1.4.3.0
instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6) =>
         NFData2 ((,,,,,,,) a1 a2 a3 a4 a5 a6) where
  liftRnf2 r r' (x1,x2,x3,x4,x5,x6,x7,x8) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` r x7 `seq` r' x8

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9) =>
         NFData (a1, a2, a3, a4, a5, a6, a7, a8, a9) where rnf = rnf2
-- |@since 1.4.3.0
instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8) =>
         NFData1 ((,,,,,,,,) a1 a2 a3 a4 a5 a6 a7 a8) where liftRnf = liftRnf2 rnf
-- |@since 1.4.3.0
instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7) =>
         NFData2 ((,,,,,,,,) a1 a2 a3 a4 a5 a6 a7) where
  liftRnf2 r r' (x1,x2,x3,x4,x5,x6,x7,x8,x9) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` r x8 `seq` r' x9

----------------------------------------------------------------------------
-- ByteArray

#if BYTEARRAY_IN_BASE
-- |@since 1.4.6.0
instance NFData ByteArray where
  rnf (ByteArray _) = ()
#endif


{-|
Module      : Language.Rust.Inline.Context
Description : Defines contexts (rules mapping Rust types to Haskell types)
Copyright   : (c) Alec Theriault, 2017
License     : BSD-style
Maintainer  : alec.theriault@gmail.com
Stability   : experimental
Portability : GHC
-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}

module Language.Fortran.Inline.Context where

import Language.Fortran.Inline.Pretty ( renderType )

import Language.Fortran.Quote         ( ty )
import Language.Fortran.Syntax        ( Ty(..), Abi(..), FnDecl(..),
                                     Arg(..), Mutability(..), Unsafety(..) )

import Language.Haskell.TH

--import Data.Semigroup             hiding (Arg)
import Data.Monoid
import Data.Typeable               ( Typeable )
import Control.Monad               ( void, liftM2 )
import Data.Traversable            ( for )
import Data.List                   ( intercalate )

--import Data.Int                    ( Int8, Int16, Int32, Int64 )
--import Data.Word                   ( Word8, Word16, Word32, Word64 )
import Foreign.C.Types             -- pretty much every type here is used

import GHC.Exts                    ( Char#, Int#, Word#, Float#, Double#,
--                                   ByteArray#
                                   )

import qualified Control.Monad.Fail as Fail
import Eigen.Internal -- CComplex
import qualified Data.Vector.Storable.Mutable as VM
import qualified Data.Vector.Storable as V
--import qualified Debug.Trace as D

import Language.Rust.Data.Position
import Foreign hiding (void)

--import Data.Complex

instance Fail.MonadFail First where
  fail x = error $ "MonadFail First error: " ++ x

--start for Vector Context
type CArray = Ptr

-- Easier on the eyes
type RType = Ty ()
type HType = Type

-- | Represents a prioritized set of rules for mapping Haskell types into Rust
-- ones and vice versa.
--
-- The 'Context' argument encodes the fact that we may need look
-- recursively into the 'Context' again before possibly producing a Haskell
-- type.
newtype Context =
    Context ( [ RType -> Context -> First (Q HType, Maybe (Q RType),String) ]
            -- Given a Rust type in a quasiquote, we need to look up the
            -- corresponding Haskell type (for the FFI import) as well as the
            -- C-compatible Rust type (if the initial Rust type isn't already
            -- @#[repr(C)]@.

            , [ HType -> Context -> First (Q RType) ]
            -- Given a field in a Haskell ADT, we need to figure out which
            -- (not-necessarily @#[repr(C)]@) Rust type normally maps into this
            -- Haskell type.

            , [ String ]
            -- Source for the trait impls of @MarshalTo@
            , String
            )
  deriving (Semigroup, Monoid, Typeable)

-- | Applicative lifting of the 'Context' instance
instance Semigroup (Q Context) where
  (<>) = liftM2 (<>)

-- | Applicative lifting of the 'Context' instance
instance Monoid (Q Context) where
  mappend = (<>)
  mempty = pure mempty

-- | Search in a 'Context' for the Haskell type corresponding to a Rust type.
-- If the Rust type is not C-compatible, also return a C compatible type. It is
-- expected that:
--
--   1. The Haskell type have a 'Storable' instance
--   2. The C-compatible Rust type have the same layout
--
lookupRTypeInContext :: RType -> Context -> First (Q HType, Maybe (Q RType),String)
lookupRTypeInContext rustType context@(Context (rules, _, _,_)) =
  foldMap (\fits -> fits rustType context) rules

isFProcedurePtr :: RType -> Bool
isFProcedurePtr (FProcedurePtr _ _ _ _) = True
isFProcedurePtr _ = False

-- | Search in a 'Context' for the Rust type corresponding to a Haskell type.
-- Looking up the Rust type using 'lookupRTypeInContext' should yield the
-- initial Haskell type again.
lookupHTypeInContext :: HType -> Context -> First (Q RType)
lookupHTypeInContext haskType context@(Context (_, rules, _,_)) =
  foldMap (\fits -> fits haskType context) rules

-- | Partial version of 'lookupRTypeInContext' that fails with an error message
-- if the type is not convertible.
getRTypeInContext :: RType -> Context -> (Q HType, Maybe (Q RType),String)
getRTypeInContext rustType context =
  let x = takeIdContext context
   in case getFirst (lookupRTypeInContext rustType context) of
    Just found -> found
    Nothing -> ( fail $ unwords [ "Could not find information about"
                                , renderType rustType
                                , "in the context " ++ x ++ " : " ++ show rustType
                                ]
               , Nothing, "failed" )

takeIdContext :: Context -> String
takeIdContext (Context (_,_,_,i)) = i

-- | Partial version of 'lookupHTypeInContext' that fails with an error message
-- if the type is not convertible.
getHTypeInContext :: HType -> Context -> Q RType
getHTypeInContext haskType context =
  case getFirst (lookupHTypeInContext haskType context) of
    Just found -> found
    Nothing -> fail $ unwords [ "Could not find information about"
                              , pprint haskType
                              , "in the context"
                              ]

-- | Make a 'Context' consisting of rules to map the Rust types on the left to
-- the Haskell types on the right. The Rust types should all be @#[repr(C)]@
-- and the Haskell types should all be 'Storable'.
mkContext :: String -> [(Ty a, Q HType, Bool,String)] -> Q Context
mkContext idContext tys = do
    tys' <- traverse (\(rt,qht,mkImpl,idSubcon) -> do { ht <- qht; pure (void rt,ht,mkImpl,idSubcon) }) tys
    pure (Context ( map fits tys'
                  , map rev tys'
                  , map impl tys'
                  , idContext
                  ))
  where
    fits (rts, hts, _, i) rt _ | rt == rts = pure (pure hts, Nothing,i)
                            | otherwise = mempty

    rev (rts, hts, _,_) ht _  | ht == hts = pure (pure rts)
                            | otherwise = mempty

    impl (rts, _, mkImpl,_)   | mkImpl = implMarshalInto rts
                            | otherwise = mempty

-- | Make a default @MarshalInto@ trait impl. (An identity impl)
implMarshalInto :: Ty () -> String
implMarshalInto t = unlines [ "impl MarshalInto<" ++ tyStr ++ "> for " ++ tyStr ++ " {"
                             , "  fn marshal(self) -> " ++ tyStr ++ " { self }"
                             , "}"
                             ]
  where tyStr = renderType t

-- | Make a singleton 'Context' consisting of a rule to map the given Rust type
-- to the given Haskell type.
singleton :: Ty a -> Q HType -> Q Context
singleton rts qht = mkContext "singleton" [(rts, qht, True,"singleton")]

-- * Some handy contexts

-- | Types defined in 'Foreign.C.Types' and the 'libc' crate.
--
-- There should be no conversion required here - these have /identical/ memory
-- layouts (since they both promise to have the same memory layout as C) and are
-- passed on the stack.
libc :: Q Context
libc = mkContext "libc" []
--h--  [ ([ty| libc::c_char      |], [t| CChar      |], False) -- char
--h--  , ([ty| libc::c_schar     |], [t| CSChar     |], False) -- signed char
--h--  , ([ty| libc::c_uchar     |], [t| CUChar     |], False) -- unsigned char
--h--  , ([ty| libc::c_short     |], [t| CShort     |], False) -- short
--h--  , ([ty| libc::c_ushort    |], [t| CUShort    |], False) -- unsigned short
--h--  , ([ty| libc::c_int       |], [t| CInt       |], False) -- int
--h--  , ([ty| libc::c_uint      |], [t| CUInt      |], False) -- unsigned int
--h--  , ([ty| libc::c_long      |], [t| CLong      |], False) -- long
--h--  , ([ty| libc::c_ulong     |], [t| CULong     |], False) -- unsigned long
--h--  , ([ty| libc::ptrdiff_t   |], [t| CPtrdiff   |], False) -- ptrdiff_t
--h--  , ([ty| libc::size_t      |], [t| CSize      |], False) -- size_t
--h--  , ([ty| libc::wchar_t     |], [t| CWchar     |], False) -- wchar_t
--h--  , ([ty| libc::c_longlong  |], [t| CLLong     |], False) -- long long
--h--  , ([ty| libc::c_ulonglong |], [t| CULLong    |], False) -- unsigned long long
--h--  , ([ty| libc::boolean_t   |], [t| CBool      |], False) -- bool
--h--  , ([ty| libc::intptr_t    |], [t| CIntPtr    |], False) -- intptr_t
--h--  , ([ty| libc::uintptr_t   |], [t| CUIntPtr   |], False) -- uintptr_t
--h--  , ([ty| libc::intmax_t    |], [t| CIntMax    |], False) -- intmax_t
--h--  , ([ty| libc::uintmax_t   |], [t| CUIntMax   |], False) -- unsigned intmax_t
--h--  , ([ty| libc::clock_t     |], [t| CClock     |], False) -- clock_t
--h--  , ([ty| libc::time_t      |], [t| CTime      |], False) -- time_t
--h--  , ([ty| libc::useconds_t  |], [t| CUSeconds  |], False) -- useconds_t
--h--  , ([ty| libc::suseconds_t |], [t| CSUSeconds |], False) -- suseconds_t
--h--  , ([ty| libc::c_float     |], [t| CFloat     |], False) -- float
--h--  , ([ty| libc::c_double    |], [t| CDouble    |], False) -- double
--h--  , ([ty| libc::FILE        |], [t| CFile      |], True)  -- FILE
--h--  , ([ty| libc::fpos_t      |], [t| CFpos      |], True)  -- fpos_t
--h--  , ([ty| libc::int8_t      |], [t| Int8       |], False) -- int8_t
--h--  , ([ty| libc::int16_t     |], [t| Int16      |], False) -- int16_t
--h--  , ([ty| libc::int32_t     |], [t| Int32      |], False) -- int32_t
--h--  , ([ty| libc::int64_t     |], [t| Int64      |], False) -- int64_t
--h--  , ([ty| libc::uint8_t     |], [t| Word8      |], False) -- uint8_t
--h--  , ([ty| libc::uint16_t    |], [t| Word16     |], False) -- uint16_t
--h--  , ([ty| libc::uint32_t    |], [t| Word32     |], False) -- uint32_t
--h--  , ([ty| libc::uint64_t    |], [t| Word64     |], False) -- uint64_t
--h--  ]

vecCtx :: Q Context
vecCtx = mkContext "vecCtx"
  [ ([ty| vecptr |], [t| VM.IOVector |], True ,"vecptr")
  , ([ty| veclen |], [t| Int |], True         ,"veclen")
  ]
-- | Basic numeric (and similar) Haskell and Rust types.
--
-- There should be no conversion required here as these should have identical
-- memory layouts.
basic :: Q Context
basic = do
  runIO $ putStrLn $  "=====debug:" ++ show [ty| character |]
  mkContext "basic"
    [ ([ty| char  |], [t| Char    |], True, "char ") -- 4 bytes
    , ([ty| i8    |], [t| Int8    |], True, "i8   ")
    , ([ty| i16   |], [t| Int16   |], True, "i16  ")
    , ([ty| i32   |], [t| Int32   |], True, "i32  ")
    , ([ty| i64   |], [t| Int64   |], True, "i64  ")
    , ([ty| u8    |], [t| Word8   |], True, "u8   ")
    , ([ty| u16   |], [t| Word16  |], True, "u16  ")
    , ([ty| u32   |], [t| Word32  |], True, "u32  ")
    , ([ty| u64   |], [t| Word64  |], True, "u64  ")
    , ([ty| f32   |], [t| Float   |], True, "f32  ")
    , ([ty| f64   |], [t| Double  |], True, "f64  ")
    , ([ty| isize |], [t| Int     |], True, "isize")
    , ([ty| usize |], [t| Word    |], True, "usize")
    , ([ty| bool  |], [t| Word8   |], True, "bool ")
    , ([ty| ()    |], [t| ()      |], True, "()   ")
--   Fortran
    , ([ty| integer       |], [t| Int            |], True , "integer     ")
    , ([ty| logical       |], [t| Bool            |], True , "logical     ")
    , ([ty| real          |], [t| Float           |], True , "real        ")
--  , ([ty| complex       |], [t| CComplex Float  |], True , "complex     ")
    , ([ty| complex(kind=8) |], [t| Ptr (CComplex Float) |], True , "complexFloat")
    , ([ty| complex(kind=16) |], [t| Ptr (CComplex Double) |], True , "complexDouble ")
    , ([ty| character     |], [t| Char           |], True , "character   ")
    , ([ty| real(kind=8)  |], [t| Double         |], True , "real(kind=8)")
    , ((FString (Span NoPosition NoPosition)), [t|CChar |], True, "FString")
    {-
    , ([ty| logical(kind=1) |], [t| Int8            |])
    , ([ty| character(len=1)|], [t| CChar           |])
--    , ([ty| integer         |], [t| CInt            |])
--    , ([ty| integer(kind=2) |], [t| CShort          |])
--    , ([ty| integer(kind=4) |], [t| CInt            |])
--    , ([ty| integer(kind=4) |], [t| CLong           |])
--    , ([ty| integer(kind=8) |], [t| CLLong          |])
--    , ([ty| integer(kind=1) |], [t| CChar           |])
--    , ([ty| integer(kind=4) |], [t| CSize           |])
    , ([ty| integer(kind=1) |], [t| Int8            |])
    , ([ty| integer(kind=2) |], [t| Int16           |])
    , ([ty| integer(kind=4) |], [t| Int32           |])
    , ([ty| integer(kind=8) |], [t| Int64           |])
    , ([ty| real(kind=4)    |], [t| Float           |])
    , ([ty| complex(kind=4) |], [t| CComplex Float  |])
    , ([ty| complex(kind=8) |], [t| CComplex Double |])
    -}
    ]

-- | Basic unboxed Haskell types
--
-- TODO: MutableByteArray#
ghcUnboxed :: Q Context
ghcUnboxed = do
  mkContext "ghcUnboxed"
    [ ([ty| char      |], [t| Char#      |], False, "char  ")
    , ([ty| isize     |], [t| Int#       |], False, "isize ")
    , ([ty| usize     |], [t| Word#      |], False, "usize ")
    , ([ty| f32       |], [t| Float#     |], False, "f32   ")
    , ([ty| f64       |], [t| Double#    |], False, "f64   ")
--    , ([ty| *const i8 |], [t| ByteArray# |], False)
    ]

-- | Haskell pointers map onto Rust pointers. Note that unlike Rust, Haskell
-- doesn't really distinguish between pointers pointing to immutable memory from
-- those pointing to to mutable memory, so it is up to the user to enforce this.
--
-- NOTE: pointers will not support pointed types that require an intermediate
--       Rust type.
  {-
fImmutableVectors :: Q Context
fImmutableVectors = do
  vecConT <- [t| V.Vector |]
  pure (Context ([rule], [rev vecConT], [], "fImmutableVectors"))
  where
  rule vec context = do
    FArray _ t _  <- pure vec
    (t', Nothing) <- lookupRTypeInContext t context
    pure ([t| $t' |], Nothing)

  rev vecConT pt context = do
    AppT vecCon t <- pure pt
    if vecCon /= vecConT
      then mempty
      else do
        t' <- lookupHTypeInContext t context
        pure (FArray (-1) <$> t' <*> pure ())
        --pure (Ptr Mutable <$> t' <*> pure ())

fComplex :: Q Context
fComplex = do
  vecConT <- [t| Complex |]
  pure (Context ([rule], [rev vecConT], [], "fComplex"))
  where
  rule vec context = do
    ff <- pure vec
    case ff of
      (FArray _ t _) -> do
        (t', Nothing,i) <- lookupRTypeInContext t context
        pure ([t| Ptr $t' |], Nothing,i)
      _ -> mempty

  rev vecConT pt context = do
    AppT vecCon t <- pure pt
    if vecCon /= vecConT
      then mempty
      else do
        t' <- lookupHTypeInContext t context
        pure (FArray (-1) <$> t' <*> pure ())
        --pure (Ptr Mutable <$> t' <*> pure ())
-}

fVectors :: Q Context
fVectors = do
  vecConT <- [t| VM.MVector |]
  pure (Context ([rule], [rev vecConT], [], "fVectors"))
  where
  rule vec context = do
    ff <- pure vec
    case ff of
      (FArray _ t _) -> do
        (t', Nothing,i) <- lookupRTypeInContext t context
        pure ([t| Ptr $t' |], Nothing,i)
      _ -> mempty

  rev vecConT pt context = do
    AppT vecCon t <- pure pt
    if vecCon /= vecConT
      then mempty
      else do
        t' <- lookupHTypeInContext t context
        pure (FArray (-1) <$> t' <*> pure ())
        --pure (Ptr Mutable <$> t' <*> pure ())

vectors :: Q Context
vectors = do
  vecConT <- [t| V.MVector |]
  pure (Context ([rule], [rev vecConT], [], "vectors"))
  where
  rule vec context = do
    Array t _ _  <- pure vec
--    V.MVector t _  <- pure vec
    (t', Nothing,i) <- lookupRTypeInContext t context
    pure ([t| Ptr $t' |], Nothing,i)

  rev vecConT pt context = do
    AppT vecCon t <- pure pt
    if vecCon /= vecConT
      then mempty
      else do
        t' <- lookupHTypeInContext t context
        pure (Ptr Mutable <$> t' <*> pure ())

pointers :: Q Context
pointers = do
    ptrConT <- [t| Ptr |]
    pure (Context ([rule],[rev ptrConT],[constPtr,mutPtr],"pointers"))
  where
  rule pt context = do
    ff <- pure pt
    case ff of
      FOptional t _ -> do
        (t', Nothing,i) <- lookupRTypeInContext t context
        pure ([t| $t' |], Nothing,i)
      FByReference t _ -> do
        (t', Nothing,i) <- lookupRTypeInContext t context
        pure ([t| Ptr $t' |], Nothing,i)
      _ -> mempty

  rev ptrConT pt context = do
    AppT ptrCon t <- pure pt
    if ptrCon /= ptrConT
      then mempty
      else do
        t' <- lookupHTypeInContext t context
        pure (FByReference <$> t' <*> pure ())

  constPtr = unlines [ "impl<T> MarshalInto<*const T> for *const T {"
                     , "  fn marshal(self) -> *const T { self }"
                     , "}"
                     ]

  mutPtr =   unlines [ "impl<T> MarshalInto<*mut T> for *mut T {"
                     , "  fn marshal(self) -> *mut T { self }"
                     , "}"
                     ]

-- | This maps a Rust function type into the corresponding 'FunPtr' wrapped
-- Haskell function type.
--
-- Note that as a user, you are still responsible for marshalling values of
-- type 'FunPtr'. The reason for this is simple: the GHC runtime has no way of
-- automatically detecting when a pointer to a function is no longer present on
-- the Rust side.
--
-- NOTE: function pointers will not support pointed types that require an intermediate
--       Rust type.

makeIO :: Q HType -> Q HType
makeIO x = do
  ioT <- [t| IO |]
  x1 <- x
  xx <- case x1 of
          AppT i _ -> if i == ioT then x
                                  else [t| IO $x |]
          _ -> [t| IO $x |]
  return xx

--joinPtr :: HType -> HType -> HType
--joinPtr ptrConT a@(AppT p r)
--  | p /= ptrConT = AppT ptrConT a
--  | otherwise = joinPtr ptrConT r
joinPtr :: HType -> HType -> HType
joinPtr ptrConT o@(AppT p2 r@(AppT p3 _))
  | p2 == p3 && ptrConT == p2 = joinPtr ptrConT r
  | otherwise = o
joinPtr _ a = a

functions :: Q Context
functions = do
  funPtrT <- [t| FunPtr |]
  ioT <- [t| IO |]
  ptrConT <- [t| Ptr |]
  pure (Context ([rule ptrConT], [rev funPtrT ioT], [impl],"functions"))
  where
  rule :: HType -> RType -> Context -> First (Q HType, Maybe (Q RType),String)
  rule pt ft context = do
    --BareFn _ C _ (FnDecl args retTy False _) _ <- pure ft
    ff <- pure ft
    case ff of
      (FProcedurePtr _ retTy argTys _) -> do
        args' <- for argTys $ \arg -> do
          (t',_,_) <- lookupRTypeInContext arg context
          pure $ joinPtr pt <$> t'
        retTy' <- do
          (t',_,_) <- lookupRTypeInContext retTy context
          pure t'
        --retTy2 <- pure $ makeIO <$> retTy'
        let retTy2 :: Q HType
            retTy2 = makeIO retTy'
        let hFunTy = foldr (\l r -> [t| $l -> $r |]) retTy2 args'
        let hFunPtr = [t| FunPtr $hFunTy |]
        pure (hFunPtr, Nothing,"FProcedurePtr")
      _ -> mempty

  rev :: Type -> Type -> HType -> Context -> First (Q RType)
  rev funPtrT ioT ft context = do
    AppT funPtr t <- pure ft
    if funPtr /= funPtrT
      then mempty
      else do
        let ts = getApps t
            args = init ts

            ret   = last ts
            ret'  = case ret of
                      AppT io r | io == ioT -> r
                      r -> r
            ret'' = case ret' of
                      TupleT 0 -> Nothing
                      r -> Just r

        argsRs <- traverse (`lookupHTypeInContext` context) args
        retRs <- traverse (`lookupHTypeInContext` context) ret''
        let argsRs' :: Q [Arg ()]
            argsRs' = map (\a -> Arg Nothing a ()) <$> sequence argsRs
--          argsRs2 :: Q [RType]
--          argsRs2 = sequence argsRs
        let decl = FnDecl <$> argsRs' <*> sequence retRs <*> pure False <*> pure ()
        pure (BareFn Normal C [] <$> decl <*> pure ())
--        pure (FProcedurePtr "dummy" retRs argsRs2 <*> pure mempty )
--

  getApps :: Type -> [Type]
  getApps (AppT e1 e2) = e1 : getApps e2
  getApps e = [e]

  -- TODO: this only goes up to 16
  impl :: String
  impl = unlines (map implN [1..16])

    where
    vars = [ l : i | i <- "" : map show [(1 :: Int)..], l <- ['T'..'Z'] ]

    implN :: Int -> String
    implN n = let vs = intercalate "," (take n vars)
                  f = "extern \"C\" fn (" ++ vs ++ ") -> R"
              in unlines [ "impl<" ++ vs ++ ",R> MarshalInto<" ++ f ++ "> for (" ++ f ++ ") {"
                         , "  fn marshal(self) -> (" ++ f ++ ") { self }"
                         , "}"
                         ]


module FxForHasql.Prelude
(
  module Exports,
)
where

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

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

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

-- fx
-------------------------
import Fx as Exports


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Data.Store.TH.Internal
    (
    -- * TH functions for generating Store instances
      deriveManyStoreFromStorable
    , deriveTupleStoreInstance
    , deriveGenericInstance
    , deriveManyStorePrimVector
    , deriveManyStoreUnboxVector
    , deriveStore
    , makeStore
    -- * Misc utilties used in Store test
    , getAllInstanceTypes1
    , isMonoType
    ) where

import           Control.Applicative
import           Data.Complex ()
import           Data.Generics.Aliases (extT)
import           Data.Generics.Schemes (listify, everywhere)
import           Data.List (find, nub)
import qualified Data.Map as M
import           Data.Maybe (fromMaybe)
import           Data.Primitive.ByteArray
import           Data.Primitive.Types
import           Data.Store.Core
import           Data.Store.Impl
import qualified Data.Text as T
import           Data.Traversable (forM)
import qualified Data.Vector.Primitive as PV
import qualified Data.Vector.Unboxed as UV
import           Data.Word
import           Foreign.Storable (Storable)
import           GHC.Types (Int(..))
import           Language.Haskell.TH
import           Language.Haskell.TH.ReifyMany.Internal (TypeclassInstance(..), getInstances, unAppsT)
import           Language.Haskell.TH.Syntax (lift)
import           Prelude
import           Safe (headMay)
import           TH.Derive (Deriver(..))
import           TH.ReifySimple
import           TH.Utilities (expectTyCon1, dequalify, plainInstanceD, appsT)

instance Deriver (Store a) where
    runDeriver _ preds ty = do
        argTy <- expectTyCon1 ''Store ty
        dt <- reifyDataTypeSubstituted argTy
        (:[]) <$> deriveStore preds argTy (dtCons dt)

-- | Given the name of a type, generate a Store instance for it,
-- assuming that all type variables also need to be Store instances.
--
-- Note that when used with datatypes that require type variables, the
-- ScopedTypeVariables extension is required.
makeStore :: Name -> Q [Dec]
makeStore name = do
    dt <- reifyDataType name
    let preds = map (storePred . VarT) (dtTvs dt)
        argTy = appsT (ConT name) (map VarT (dtTvs dt))
    (:[]) <$> deriveStore preds argTy (dtCons dt)

deriveStore :: Cxt -> Type -> [DataCon] -> Q Dec
deriveStore preds headTy cons0 =
    makeStoreInstance preds headTy
        <$> sizeExpr
        <*> peekExpr
        <*> pokeExpr
  where
    cons :: [(Name, [(Name, Type)])]
    cons =
      [ ( dcName dc
        , [ (mkName ("c" ++ show ixc ++ "f" ++ show ixf), ty)
          | ixf <- ints
          | (_, ty) <- dcFields dc
          ]
        )
      | ixc <- ints
      | dc <- cons0
      ]
    -- NOTE: tag code duplicated in th-storable.
    (tagType, _, tagSize) =
        fromMaybe (error "Too many constructors") $
        find (\(_, maxN, _) -> maxN >= length cons) tagTypes
    tagTypes :: [(Name, Int, Int)]
    tagTypes =
        [ ('(), 1, 0)
        , (''Word8, fromIntegral (maxBound :: Word8), 1)
        , (''Word16, fromIntegral (maxBound :: Word16), 2)
        , (''Word32, fromIntegral (maxBound :: Word32), 4)
        , (''Word64, fromIntegral (maxBound :: Word64), 8)
        ]
    fName ix = mkName ("f" ++ show ix)
    ints = [0..] :: [Int]
    fNames = map fName ints
    sizeNames = zipWith (\_ -> mkName . ("sz" ++) . show) cons ints
    tagName = mkName "tag"
    valName = mkName "val"
    sizeExpr =
        caseE (tupE (concatMap (map sizeAtType . snd) cons))
              (if null sizeNames then [matchConstSize] else [matchConstSize, matchVarSize])
      where
        sizeAtType :: (Name, Type) -> ExpQ
        sizeAtType (_, ty) = [| size :: Size $(return ty) |]
        matchConstSize :: MatchQ
        matchConstSize = do
            let sz0 = VarE (mkName "sz0")
                sizeDecls =
                    if null sizeNames
                        then [valD (varP (mkName "sz0")) (normalB [| 0 |]) []]
                        else zipWith constSizeDec sizeNames cons
            sameSizeExpr <-
                case sizeNames of
                    (_ : tailSizeNames) ->
                        foldl (\l r -> [| $(l) && $(r) |]) [| True |] $
                        map (\szn -> [| $(return sz0) == $(varE szn) |]) tailSizeNames
                    [] -> [| True |]
            result <- [| ConstSize (tagSize + $(return sz0)) |]
            match (tupP (map (\(n, _) -> conP 'ConstSize [varP n])
                             (concatMap snd cons)))
                  (guardedB [return (NormalG sameSizeExpr, result)])
                  sizeDecls
        constSizeDec :: Name -> (Name, [(Name, Type)]) -> DecQ
        constSizeDec szn (_, []) =
            valD (varP szn) (normalB [| 0 |]) []
        constSizeDec szn (_, fields) =
            valD (varP szn) body []
          where
            body = normalB $
                foldl1 (\l r -> [| $(l) + $(r) |]) $
                map (\(sizeName, _) -> varE sizeName) fields
        matchVarSize :: MatchQ
        matchVarSize = do
            match (tupP (map (\(n, _) -> varP n) (concatMap snd cons)))
                  (normalB [| VarSize $ \x -> tagSize +
                                  $(caseE [| x |] (map matchVar cons)) |])
                  []
        matchVar :: (Name, [(Name, Type)]) -> MatchQ
        matchVar (cname, []) =
            match (conP cname []) (normalB [| 0 |]) []
        matchVar (cname, fields) =
            match (conP cname (zipWith (\_ fn -> varP fn) fields fNames))
                  body
                  []
          where
            body = normalB $
                foldl1 (\l r -> [| $(l) + $(r) |])
                (zipWith (\(sizeName, _) fn -> [| getSizeWith $(varE sizeName) $(varE fn) |])
                         fields
                         fNames)
    -- Choose a tag size large enough for this constructor count.
    -- Expression used for the definition of peek.
    peekExpr = case cons of
        [] -> [| error ("Attempting to peek type with no constructors (" ++ $(lift (show headTy)) ++ ")") |]
        [con] -> peekCon con
        _ -> doE
            [ bindS (varP tagName) [| peek |]
            , noBindS (caseE (sigE (varE tagName) (conT tagType))
                      (map peekMatch (zip [0..] cons) ++ [peekErr]))
            ]
    peekMatch (ix, con) = match (litP (IntegerL ix)) (normalB (peekCon con)) []
    peekErr = match wildP (normalB
        [| peekException $ T.pack $ "Found invalid tag while peeking (" ++ $(lift (show headTy)) ++ ")" |]) []
    peekCon (cname, fields) =
        case fields of
            [] -> [| pure $(conE cname) |]
            _ -> doE $
                map (\(fn, _) -> bindS (varP fn) [| peek |]) fields ++
               [noBindS $ appE (varE 'return) $ appsE $ conE cname : map (\(fn, _) -> varE fn) fields]
    pokeExpr = lamE [varP valName] $ caseE (varE valName) $ zipWith pokeCon [0..] cons
    pokeCon :: Int -> (Name, [(Name, Type)]) -> MatchQ
    pokeCon ix (cname, fields) =
        match (conP cname (map (\(fn, _) -> varP fn) fields)) body []
      where
        body = normalB $
            case cons of
                (_:_:_) -> doE (pokeTag ix : map pokeField fields)
                _ -> doE (map pokeField fields)
    pokeTag ix = noBindS [| poke (ix :: $(conT tagType)) |]
    pokeField (fn, _) = noBindS [| poke $(varE fn) |]

-- FIXME: make this work even when there are too many fields

-- FIXME: make the ConstSize stuff explicit in the API. Have an option
-- that always errors at runtime if it isn't ConstSize?

-- TODO: It would be really awesome, though a bit tricky, to know at
-- compile time if we have a static size.

-- TODO: make sure that this tends to optimize even with tons of fields.
-- It should also optimize when some fields are known to be , but others
-- are unknown (determined by polymorphic var)

{- What the generated code looks like

data Foo = Foo Int Double Float

instance Store Foo where
    size =
        case (size :: Size Int, size :: Size Double, size :: Size Float) of
            (ConstSize c0f0, ConstSize c0f1, ConstSize c0f2) -> ConstSize (0 + sz0)
              where
                sz0 = c0f0 + c0f1 + c0f2
            (c0f0, c0f1, c0f2)
                VarSize $ \(Foo f0 f1 f2) -> 0 +
                    getSizeWith c0f0 f0 + getSizeWith c0f1 f1 + getSizeWith c0f2 f2
    peek = do
        f0 <- peek
        f1 <- peek
        f2 <- peek
        return (Foo f0 f1 f2)
    poke (Foo f0 f1 f2) = do
        poke f0
        poke f1
        poke f2

data Bar = Bar Int | Baz Double

instance Store Bar where
    size =
        case (size :: Size Int, size :: Size Double) of
            (ConstSize c0f0, ConstSize c1f0) | sz0 == sz1 -> ConstSize (1 + sz0)
              where
                sz0 = c0f0
                sz1 = c1f0
            (c0f0, c1f0) -> VarSize $ \x -> 1 +
                case x of
                    Bar f0 -> getSizeWith c0f0 f0
                    Baz f0 -> getSizeWith c1f0 f0
    peek = do
        tag <- peek
        case (tag :: Word8) of
            0 -> do
                f0 <- peek
                return (Bar f0)
            1 -> do
                f0 <- peek
                return (Baz f0)
            _ -> peekException "Found invalid tag while peeking (Bar)"
    poke (Bar f0) = do
        poke 0
        poke f0
    poke (Bar f0) = do
        poke 1
        poke f0
-}

------------------------------------------------------------------------
-- Generic

deriveTupleStoreInstance :: Int -> Dec
deriveTupleStoreInstance n =
    deriveGenericInstance (map storePred tvs)
                          (foldl1 AppT (TupleT n : tvs))
  where
    tvs = take n (map (VarT . mkName . (:[])) ['a'..'z'])

deriveGenericInstance :: Cxt -> Type -> Dec
deriveGenericInstance cs ty = plainInstanceD cs (AppT (ConT ''Store) ty) []

------------------------------------------------------------------------
-- Storable

-- TODO: Generate inline pragmas? Probably not necessary

deriveManyStoreFromStorable :: (Type -> Bool) -> Q [Dec]
deriveManyStoreFromStorable p = do
    storables <- postprocess . instancesMap <$> getInstances ''Storable
    stores <- postprocess . instancesMap <$> getInstances ''Store
    return $ M.elems $ flip M.mapMaybe (storables `M.difference` stores) $
        \(TypeclassInstance cs ty _) ->
        let argTy = head (tail (unAppsT ty))
            tyNameLit = LitE (StringL (pprint ty)) in
        if p argTy
            then Just $ makeStoreInstance cs argTy
                (AppE (VarE 'sizeStorableTy) tyNameLit)
                (AppE (VarE 'peekStorableTy) tyNameLit)
                (VarE 'pokeStorable)
            else Nothing

------------------------------------------------------------------------
-- Vector

deriveManyStorePrimVector :: Q [Dec]
deriveManyStorePrimVector = do
    prims <- postprocess . instancesMap <$> getInstances ''PV.Prim
    stores <- postprocess . instancesMap <$> getInstances ''Store
    let primInsts =
            M.mapKeys (map (AppT (ConT ''PV.Vector))) prims
            `M.difference`
            stores
    forM (M.toList primInsts) $ \primInst -> case primInst of
        ([_], TypeclassInstance cs ty _) -> do
            let argTy = head (tail (unAppsT ty))
            sizeExpr <- [|
                VarSize $ \x ->
                    I# $(primSizeOfExpr (ConT ''Int)) +
                    I# $(primSizeOfExpr argTy) * PV.length x
                |]
            peekExpr <- [| do
                len <- peek
                let sz = I# $(primSizeOfExpr argTy)
                array <- peekToByteArray $(lift ("Primitive Vector (" ++ pprint argTy ++ ")"))
                                         (len * sz)
                return (PV.Vector 0 len array)
                |]
            pokeExpr <- [| \(PV.Vector offset len (ByteArray array)) -> do
                let sz = I# $(primSizeOfExpr argTy)
                poke len
                pokeFromByteArray array (offset * sz) (len * sz)
                |]
            return $ makeStoreInstance cs (AppT (ConT ''PV.Vector) argTy) sizeExpr peekExpr pokeExpr
        _ -> fail "Invariant violated in derivemanyStorePrimVector"

primSizeOfExpr :: Type -> ExpQ
primSizeOfExpr ty = [| $(varE 'sizeOf#) (error "sizeOf# evaluated its argument" :: $(return ty)) |]

deriveManyStoreUnboxVector :: Q [Dec]
deriveManyStoreUnboxVector = do
    unboxes <- getUnboxInfo
    stores <- postprocess . instancesMap <$> getInstances ''Store
    let unboxInsts =
            M.fromList (map (\(preds, ty, cons) -> ([AppT (ConT ''UV.Vector) ty], (preds, cons))) unboxes)
            `M.difference`
            stores
    -- TODO: ideally this would use a variant of 'deriveStore' which
    -- assumes VarSize.
    forM (M.toList unboxInsts) $ \case
        ([ty], (preds, cons)) -> do
            {-
            -- While this approach is reasonable-ish, it ends up
            -- requiring UndecidableInstances.
            let extraPreds =
                    map (AppT (ConT ''Store)) $
                    filter (not . isMonoType) $
                    concatMap (map snd . dcFields) cons
            -}
            let extraPreds = map (storePred . AppT (ConT ''UV.Vector)) $ listify isVarT ty
            deriveStore (nub (preds ++ extraPreds)) ty cons
        _ -> fail "impossible case in deriveManyStoreUnboxVector"

-- TODO: Add something for this purpose to TH.ReifyDataType

getUnboxInfo :: Q [(Cxt, Type, [DataCon])]
getUnboxInfo = do
    FamilyI _ insts <- reify ''UV.Vector
    return (map (everywhere (id `extT` dequalVarT) . go) insts)
  where
#if MIN_VERSION_template_haskell(2,11,0)
    go (NewtypeInstD preds _ [ty] _ con _) = (preds, ty, conToDataCons con)
    go (DataInstD preds _ [ty] _ cons _) = (preds, ty, concatMap conToDataCons cons)
#else
    go (NewtypeInstD preds _ [ty] con _) = (preds, ty, conToDataCons con)
    go (DataInstD preds _ [ty] cons _) = (preds, ty, concatMap conToDataCons cons)
#endif
    go x = error ("Unexpected result from reifying Unboxed Vector instances: " ++ pprint x)
    dequalVarT (VarT n) = VarT (dequalify n)
    dequalVarT ty = ty

------------------------------------------------------------------------
-- Utilities

-- Filters out overlapping instances and instances with more than one
-- type arg (should be impossible).
postprocess :: M.Map [Type] [a] -> M.Map [Type] a
postprocess =
    M.mapMaybeWithKey $ \tys xs ->
        case (tys, xs) of
            ([_ty], [x]) -> Just x
            _ -> Nothing

makeStoreInstance :: Cxt -> Type -> Exp -> Exp -> Exp -> Dec
makeStoreInstance cs ty sizeExpr peekExpr pokeExpr =
    plainInstanceD
        cs
        (AppT (ConT ''Store) ty)
        [ ValD (VarP 'size) (NormalB sizeExpr) []
        , ValD (VarP 'peek) (NormalB peekExpr) []
        , ValD (VarP 'poke) (NormalB pokeExpr) []
        ]

-- TODO: either generate random types that satisfy instances with
-- variables in them, or have a check that there's at least a manual
-- check for polymorphic instances.

getAllInstanceTypes :: Name -> Q [[Type]]
getAllInstanceTypes n =
    map (\(TypeclassInstance _ ty _) -> drop 1 (unAppsT ty)) <$>
    getInstances n

getAllInstanceTypes1 :: Name -> Q [Type]
getAllInstanceTypes1 n =
    fmap (fmap (fromMaybe (error "getAllMonoInstances1 expected only one type argument") . headMay))
         (getAllInstanceTypes n)

isMonoType :: Type -> Bool
isMonoType = null . listify isVarT

isVarT :: Type -> Bool
isVarT VarT{} = True
isVarT _ = False

-- TOOD: move these to th-reify-many

-- | Get a map from the 'getTyHead' type of instances to
-- 'TypeclassInstance'.
instancesMap :: [TypeclassInstance] -> M.Map [Type] [TypeclassInstance]
instancesMap =
    M.fromListWith (++) .
    map (\ti -> (map getTyHead (instanceArgTypes ti), [ti]))

instanceArgTypes :: TypeclassInstance -> [Type]
instanceArgTypes (TypeclassInstance _ ty _) = drop 1 (unAppsT ty)

getTyHead :: Type -> Type
getTyHead (SigT x _) = getTyHead x
getTyHead (ForallT _ _ x) = getTyHead x
getTyHead (AppT l _) = getTyHead l
getTyHead x = x

storePred :: Type -> Pred
storePred ty =
#if MIN_VERSION_template_haskell(2,10,0)
        AppT (ConT ''Store) ty
#else
        ClassP ''Store [ty]
#endif