{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE UndecidableInstances #-}
{-|

Deprecated - use storable-static-array instead.

This module defines 'FixedStorableArray', a simple wrapper around
'StorableArray' with its dimensions encoded in the
type. 'FixedStorableArray' provides a 'Storable' instance that uses
the type-level dimensions, and significantly eases writing FFI
bindings to fixed-size native arrays. For example,
@'FixedStorableArray' 10 CInt@ has a 'Storable' instance that is
directly compatible with @int foo[10]@ in native code.

Multidimensional native arrays are also
supported. @'FixedStorableArray' \'(10,20,100) CUChar@ is compatible
with @unsigned char foo[10][20][100]@. Note the leading @\'@ before
the tuple containing the dimensions. It marks it as a @DataKinds@
lifted tuple, necessary to store the dimensions.

To operate on the contents of a 'FixedStorableArray', use
'toStorableArray'. 'toStorableArray' returns a 'StorableArray' with
the correct type and index values already in place. For example, the
result of 'toStorableArray' on a @'FixedStorableArray' \'(10,20,100)
CUChar@ is a @'StorableArray' (Int, Int, Int) CUChar@ with its bounds
set to @((0,0,0),(9,19,99))@.

-}
module Foreign.Marshal.FixedStorableArray
       ( FixedStorableArray
       , newFixedStorableArray
       , newFixedStorableArray_
       , toStorableArray
       , HasBounds(..)
       , fromNat
       ) where

import GHC.TypeLits

import Data.Array.Storable
import Data.Functor          ((<$>))
import Data.Proxy            (Proxy(..))

import Foreign.Storable      (Storable(..))
import Foreign.Marshal.Array (copyArray)
import Foreign.Ptr           (castPtr)


-- | A minimal wrapper for 'StorableArray' that encodes the full
-- dimensions of the array in the type. Intended for interfacing with
-- (possibly-)multidimensional arrays of fixed size in native code.
newtype FixedStorableArray dimensions e =
    FixedStorableArray {
        -- | Returns the backing 'StorableArray' of this
        -- 'FixedStorableArray'. The backing array is shared such that
        -- modifications to it will be seen across all uses of this
        -- 'FixedStorableArray'.
        toStorableArray :: StorableArray (Bound dimensions) e }

-- | This class connects dimension description types with
-- 'StorableArray' index types and values. Instances are provided for
-- up to 13 dimensions. More can be added if there's any need.
class HasBounds d where
    -- | The bounding type for this dimension description
    type Bound d :: *
    -- | The concrete bounds for this dimension
    bounds :: FixedStorableArray d e -> (Bound d, Bound d)

-- | Create a 'FixedStorableArray' and populate it with copies of the
-- element passed in. Dimensions will be determined from the return
-- type.
newFixedStorableArray :: (HasBounds d, Ix (Bound d), Storable e) =>
                         e -> IO (FixedStorableArray d e)
newFixedStorableArray x = do
    rec let b = bounds ma
        ma <- FixedStorableArray <$> newArray b x
    return ma

-- | Create a 'FixedStorableArray' and don't populate it with anything
-- in particular. Contents may or may not be initialized to anything
-- at all. Dimensions will be determined from the return type.
newFixedStorableArray_ :: (HasBounds d, Ix (Bound d), Storable e) =>
                          IO (FixedStorableArray d e)
newFixedStorableArray_ = do
    rec let b = bounds ma
        ma <- FixedStorableArray <$> newArray_ b
    return ma

instance (HasBounds d, Ix (Bound d), Storable e) =>
         Storable (FixedStorableArray d e) where
    sizeOf a = sizeOf (undefined :: e) * rangeSize (bounds a)
    alignment _ = alignment (undefined :: e)
    peek src' = do
        ma <- newFixedStorableArray_
        let sa = toStorableArray ma
            src = castPtr src'
        count <- rangeSize <$> getBounds sa
        withStorableArray sa $ \dst -> copyArray dst src count
        return ma
    poke dst' ma = do
        let sa = toStorableArray ma
            dst = castPtr dst'
        count <- rangeSize <$> getBounds sa
        withStorableArray sa $ \src -> copyArray dst src count


-- | A conversion function for converting type-level naturals to
-- value-level. This is being exposed to aid in the creation of
-- additional 'HasBounds' instances for those who might desire to do
-- so.
--
-- Haddock is currently eating the important qualification that the
-- type variable @n@ must have the kind 'Nat'. The 'SingI' instance is
-- automatically fulfilled for all types of kind 'Nat'. Its explicit
-- presence in the signature is an artifact of how GHC implements
-- dictionary passing and type erasure.
fromNat :: forall (proxy :: Nat -> *) (n :: Nat). SingI n => proxy n -> Int
fromNat _ = fromInteger $ fromSing (sing :: Sing n)


----------------------------------------------------------------------------
-- HasBounds instances. More can be written, trivially - it's just a matter
-- of whether they'll ever actually be used.

instance SingI a => HasBounds (a :: Nat) where
    type Bound (a) = Int
    bounds _ = (0, fromNat (Proxy :: Proxy a) - 1)

instance (SingI a, SingI b) => HasBounds ('(a, b) :: (Nat, Nat)) where
    type Bound '(a, b) = (Int, Int)
    bounds _ = ((0, 0),
                (fromNat (Proxy :: Proxy a) - 1,
                 fromNat (Proxy :: Proxy b) - 1))

instance (SingI a, SingI b, SingI c) =>
         HasBounds ('(a, b, c) :: (Nat, Nat, Nat)) where
    type Bound '(a, b, c) = (Int, Int, Int)
    bounds _ = ((0, 0, 0),
                (fromNat (Proxy :: Proxy a) - 1,
                 fromNat (Proxy :: Proxy b) - 1,
                 fromNat (Proxy :: Proxy c) - 1))

instance (SingI a, SingI b, SingI c, SingI d) =>
         HasBounds ('(a, b, c, d) :: (Nat, Nat, Nat, Nat)) where
    type Bound '(a, b, c, d) = (Int, Int, Int, Int)
    bounds _ = ((0, 0, 0, 0),
                (fromNat (Proxy :: Proxy a) - 1,
                 fromNat (Proxy :: Proxy b) - 1,
                 fromNat (Proxy :: Proxy c) - 1,
                 fromNat (Proxy :: Proxy d) - 1))

instance (SingI a, SingI b, SingI c, SingI d, SingI e) =>
         HasBounds ('(a, b, c, d, e) :: (Nat, Nat, Nat, Nat, Nat)) where
    type Bound '(a, b, c, d, e) = (Int, Int, Int, Int, Int)
    bounds _ = ((0, 0, 0, 0, 0),
                (fromNat (Proxy :: Proxy a) - 1,
                 fromNat (Proxy :: Proxy b) - 1,
                 fromNat (Proxy :: Proxy c) - 1,
                 fromNat (Proxy :: Proxy d) - 1,
                 fromNat (Proxy :: Proxy e) - 1))

instance (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f) =>
         HasBounds ('(a, b, c, d, e, f) ::
                    (Nat, Nat, Nat, Nat, Nat, Nat)) where
    type Bound '(a, b, c, d, e, f) = (Int, Int, Int, Int, Int, Int)
    bounds _ = ((0, 0, 0, 0, 0, 0),
                (fromNat (Proxy :: Proxy a) - 1,
                 fromNat (Proxy :: Proxy b) - 1,
                 fromNat (Proxy :: Proxy c) - 1,
                 fromNat (Proxy :: Proxy d) - 1,
                 fromNat (Proxy :: Proxy e) - 1,
                 fromNat (Proxy :: Proxy f) - 1))

instance (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f, SingI g) =>
         HasBounds ('(a, b, c, d, e, f, g) ::
                    (Nat, Nat, Nat, Nat, Nat, Nat, Nat)) where
    type Bound '(a, b, c, d, e, f, g) = (Int, Int, Int, Int, Int, Int, Int)
    bounds _ = ((0, 0, 0, 0, 0, 0, 0),
                (fromNat (Proxy :: Proxy a) - 1,
                 fromNat (Proxy :: Proxy b) - 1,
                 fromNat (Proxy :: Proxy c) - 1,
                 fromNat (Proxy :: Proxy d) - 1,
                 fromNat (Proxy :: Proxy e) - 1,
                 fromNat (Proxy :: Proxy f) - 1,
                 fromNat (Proxy :: Proxy g) - 1))

instance (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f, SingI g,
          SingI h) =>
         HasBounds ('(a, b, c, d, e, f, g, h) ::
                    (Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat)) where
    type Bound '(a, b, c, d, e, f, g, h) =
        (Int, Int, Int, Int, Int, Int, Int, Int)
    bounds _ = ((0, 0, 0, 0, 0, 0, 0, 0),
                (fromNat (Proxy :: Proxy a) - 1,
                 fromNat (Proxy :: Proxy b) - 1,
                 fromNat (Proxy :: Proxy c) - 1,
                 fromNat (Proxy :: Proxy d) - 1,
                 fromNat (Proxy :: Proxy e) - 1,
                 fromNat (Proxy :: Proxy f) - 1,
                 fromNat (Proxy :: Proxy g) - 1,
                 fromNat (Proxy :: Proxy h) - 1))

instance (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f, SingI g,
          SingI h, SingI i) =>
         HasBounds ('(a, b, c, d, e, f, g, h, i) ::
                    (Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat)) where
    type Bound '(a, b, c, d, e, f, g, h, i) =
        (Int, Int, Int, Int, Int, Int, Int, Int, Int)
    bounds _ = ((0, 0, 0, 0, 0, 0, 0, 0, 0),
                (fromNat (Proxy :: Proxy a) - 1,
                 fromNat (Proxy :: Proxy b) - 1,
                 fromNat (Proxy :: Proxy c) - 1,
                 fromNat (Proxy :: Proxy d) - 1,
                 fromNat (Proxy :: Proxy e) - 1,
                 fromNat (Proxy :: Proxy f) - 1,
                 fromNat (Proxy :: Proxy g) - 1,
                 fromNat (Proxy :: Proxy h) - 1,
                 fromNat (Proxy :: Proxy i) - 1))

instance (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f, SingI g,
          SingI h, SingI i, SingI j) =>
         HasBounds ('(a, b, c, d, e, f, g, h, i, j) ::
                    (Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat)) where
    type Bound '(a, b, c, d, e, f, g, h, i, j) =
        (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int)
    bounds _ = ((0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
                (fromNat (Proxy :: Proxy a) - 1,
                 fromNat (Proxy :: Proxy b) - 1,
                 fromNat (Proxy :: Proxy c) - 1,
                 fromNat (Proxy :: Proxy d) - 1,
                 fromNat (Proxy :: Proxy e) - 1,
                 fromNat (Proxy :: Proxy f) - 1,
                 fromNat (Proxy :: Proxy g) - 1,
                 fromNat (Proxy :: Proxy h) - 1,
                 fromNat (Proxy :: Proxy i) - 1,
                 fromNat (Proxy :: Proxy j) - 1))

instance (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f, SingI g,
          SingI h, SingI i, SingI j, SingI k) =>
         HasBounds ('(a, b, c, d, e, f, g, h, i, j, k) ::
                    (Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat))
      where
    type Bound '(a, b, c, d, e, f, g, h, i, j, k) =
        (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int)
    bounds _ = ((0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
                (fromNat (Proxy :: Proxy a) - 1,
                 fromNat (Proxy :: Proxy b) - 1,
                 fromNat (Proxy :: Proxy c) - 1,
                 fromNat (Proxy :: Proxy d) - 1,
                 fromNat (Proxy :: Proxy e) - 1,
                 fromNat (Proxy :: Proxy f) - 1,
                 fromNat (Proxy :: Proxy g) - 1,
                 fromNat (Proxy :: Proxy h) - 1,
                 fromNat (Proxy :: Proxy i) - 1,
                 fromNat (Proxy :: Proxy j) - 1,
                 fromNat (Proxy :: Proxy k) - 1))

instance (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f, SingI g,
          SingI h, SingI i, SingI j, SingI k, SingI l) =>
         HasBounds ('(a, b, c, d, e, f, g, h, i, j, k, l) ::
                    (Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat,
                     Nat)) where
    type Bound '(a, b, c, d, e, f, g, h, i, j, k, l) =
        (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int)
    bounds _ = ((0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
                (fromNat (Proxy :: Proxy a) - 1,
                 fromNat (Proxy :: Proxy b) - 1,
                 fromNat (Proxy :: Proxy c) - 1,
                 fromNat (Proxy :: Proxy d) - 1,
                 fromNat (Proxy :: Proxy e) - 1,
                 fromNat (Proxy :: Proxy f) - 1,
                 fromNat (Proxy :: Proxy g) - 1,
                 fromNat (Proxy :: Proxy h) - 1,
                 fromNat (Proxy :: Proxy i) - 1,
                 fromNat (Proxy :: Proxy j) - 1,
                 fromNat (Proxy :: Proxy k) - 1,
                 fromNat (Proxy :: Proxy l) - 1))

instance (SingI a, SingI b, SingI c, SingI d, SingI e, SingI f, SingI g,
          SingI h, SingI i, SingI j, SingI k, SingI l, SingI m) =>
         HasBounds ('(a, b, c, d, e, f, g, h, i, j, k, l, m) ::
                    (Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat, Nat,
                     Nat, Nat)) where
    type Bound '(a, b, c, d, e, f, g, h, i, j, k, l, m) =
        (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int)
    bounds _ = ((0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
                (fromNat (Proxy :: Proxy a) - 1,
                 fromNat (Proxy :: Proxy b) - 1,
                 fromNat (Proxy :: Proxy c) - 1,
                 fromNat (Proxy :: Proxy d) - 1,
                 fromNat (Proxy :: Proxy e) - 1,
                 fromNat (Proxy :: Proxy f) - 1,
                 fromNat (Proxy :: Proxy g) - 1,
                 fromNat (Proxy :: Proxy h) - 1,
                 fromNat (Proxy :: Proxy i) - 1,
                 fromNat (Proxy :: Proxy j) - 1,
                 fromNat (Proxy :: Proxy k) - 1,
                 fromNat (Proxy :: Proxy l) - 1,
                 fromNat (Proxy :: Proxy m) - 1))

instance SingI n => HasBounds ('[n] :: [Nat]) where
    type Bound ('[n]) = Int
    bounds _ = (0, fromNat (Proxy :: Proxy n) - 1)

instance (SingI n, HasBounds (n2 ': ns)) =>
         HasBounds ((n ': n2 ': ns) :: [Nat]) where
    type Bound (n ': n2 ': ns) = (Int, Bound (n2 ': ns))
    bounds _ = ((0, b0), (fromNat (Proxy :: Proxy n) - 1, bn))
      where
        (b0, bn) = bounds (undefined :: FixedStorableArray (n2 ': ns) ())