{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- | Unboxed, primitive, multidimensional tables. In instance for 'Ix'-type
-- keys comes with the package. This package trades safety for speed. The index
-- operator (!) is basically the only function that does bounds-checking and
-- only with an assertion. This, however, is by design. The only way to get an
-- immutable table from a mutable one is by the 'unsafeFreezeM' operation.
-- Again, it is by design that both data structures share the same memory
-- pointer internally.
--
-- TODO We kind-of lost all but the ST monad for monadic operations.

module Data.PrimitiveArray where

import Control.Monad.Primitive (PrimMonad)
import Control.Exception (assert)
import Text.Read.Lex as L
import Text.Read
import Text.ParserCombinators.ReadP

-- * The PrimArray class.

class PrimArrayOps a b where
  -- | PrimArray data type
  data PrimArray  a b :: *
  unsafeIndex :: PrimArray a b -> a -> b  -- ^ Index an array without bounds-checking
  assocs :: PrimArray a b -> [(a,b)]      -- ^ All associations of (key,value)
  fromAssocs :: a -> a -> b -> [(a,b)] -> PrimArray a b -- ^ Pure build function
  bounds :: PrimArray a b -> (a,a)        -- ^ Min- and maxbound of all dimensions
  checkBounds :: PrimArray a b -> a -> Bool -- ^ Check if index is within bounds
  fromList :: a -> a -> [b] -> PrimArray a b  -- ^ Build the /complete/ table from a list
  toList :: PrimArray a b -> [b]          -- ^ Read the complete table as a list


class (PrimMonad s) => PrimArrayOpsM a b s where
  -- | Monadic data type
  data PrimArrayM a b s :: *
  readM :: PrimArrayM a b s -> a -> s b   -- ^ Monadic read
  writeM :: PrimArrayM a b s -> a -> b -> s ()  -- ^ Monadic write
  boundsM :: PrimArrayM a b s -> s (a,a)  -- ^ Monadic bounds
  fromAssocsM :: a -> a -> b -> [(a,b)] -> s (PrimArrayM a b s) -- ^ Build monadic array from assocs
  unsafeFreezeM :: PrimArrayM a b s -> s (PrimArray a b)  -- ^ UNSAFE freezing of array.
  fromListM :: a -> a -> [b] -> s (PrimArrayM a b s)      -- ^ Build the /complete/ monadic table from a list
  toListM :: PrimArrayM a b s -> s [b]    -- ^ Read the complete monadic table as a list



-- * Helper functions.

-- | Asserting 'unsafeIndex'. Debug-code is checked for out-of-bounds
-- occurances while production code uses unsafeIndex directly.

(!) :: (PrimArrayOps a b) => PrimArray a b -> a -> b
(!) pa idx = assert (checkBounds pa idx) $ unsafeIndex pa idx

-- | Create a new array from an old one, mapping a function over all values.

amap :: (PrimArrayOps a b, PrimArrayOps a c) => (b -> c) -> PrimArray a b -> PrimArray a c
amap f pa = fromList lb ub $ map f $ toList pa where
  (lb,ub) = bounds pa



-- * Read and show instances

-- | The Show instance looks a bit like Show for Data.Vector.Unboxed

instance (Bounded a, Show a, Show b, PrimArrayOps a b) => Show (PrimArray a b) where
  show pa = "fromList " ++ show l ++ " " ++ show u ++ " " ++ (show $ toList pa) ++ " :: Data.PrimitiveArray.PrimitiveArray" where
    (l,u) = bounds pa

-- | The Read instance follows Read for Data.Vector.Unboxed

instance (Bounded a, Read a, Read b, PrimArrayOps a b) => Read (PrimArray a b) where
  readPrec =
    parens $ do
      lift $ skipSpaces
      L.Ident "fromList" <- lexP
      lift $ skipSpaces
      (l :: a) <- readPrec
      lift $ skipSpaces
      (u :: a) <- readPrec
      (vals :: [b])  <- readPrec
      lift $ skipSpaces
      lift $ string "::"
      lift $ skipSpaces
      lift $ string "Data.PrimitiveArray.PrimitiveArray"
      lift $ skipSpaces
      return $ fromList l u vals
  readListPrec = readListPrecDefault
  readList     = readListDefault