{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
{- |
   Module     : Data.Variables
   Copyright  : Copyright (C) 2006 Bulat Ziganshin
   License    : BSD3

   Maintainer : Bulat Ziganshin <bulatz@HotPOP.com>
   Stability  : experimental
   Portability: Hugs/GHC

Syntax sugar for using pointers arithmetic and mutable variables
Monad-neutral references
Fast mutable variables in IO and ST monads
Fast monad-neutral variables
Compiler-independent unboxed values and operations on them

Based on the: Ideas of Simon Marlow and Oleg Kiselyov
              Fast integers and booleans (c) The University of Glasgow 2002
-}

module Data.Variables where

import Control.Monad
import Control.Monad.ST         (ST)
import Data.Bits
import Data.Int
import Data.IORef
import Data.STRef
import Data.Word
import Foreign.Storable
import Foreign.Ptr

#ifdef __GLASGOW_HASKELL__
import GHC.Exts
import GHC.IOBase               (IO(..))
import GHC.Unboxed
#endif


-- -----------------------------------------------------------------------------
-- Syntax sugar for using pointers arithmetic

infixl 6 +:, -:
ptr+:n   = ptr `plusPtr` (fromIntegral n)
ptr-:buf = fromIntegral  (ptr `minusPtr` buf)

{-# INLINE (+:) #-}
{-# INLINE (-:) #-}

-- -----------------------------------------------------------------------------
-- Syntax sugar for using mutable variables

infixl 0 =:, +=, -=, .=, .<-
ref x   = newMRef x
val ref = readMRef ref
ref=:x  = writeMRef ref x
ref+=x  = modifyMRef  ref (\old -> old+x)
ref-=x  = modifyMRef  ref (\old -> old-x)
ref.=f  = modifyMRef  ref (\old -> f old)
ref.<-f = modifyMRefM ref (\old -> f old)

-- -----------------------------------------------------------------------------
-- The uniform interface for mutable variables in any monad

-- |A mutable variable in some monad 'm'
--   (m->r restriction needed to simplify using of newMRef)
class (Monad m) => MRef m r | r->m, m->r where
    -- |Build a new 'MRef' with given initial value
    newMRef    :: a -> m (r a)
    -- |Read the value of an 'MRef'
    readMRef   :: r a -> m a
    -- |Write a new value into an 'MRef'
    writeMRef  :: r a -> a -> m ()

instance MRef IO IORef where
    newMRef = newIORef
    readMRef = readIORef
    writeMRef = writeIORef

instance MRef (ST s) (STRef s) where
    newMRef = newSTRef
    readMRef = readSTRef
    writeMRef = writeSTRef

-- |Modify the contents of an 'MRef' by applying pure function to it
modifyMRef  ref f  =  readMRef ref >>= writeMRef ref . f

-- |Modify the contents of an 'MRef' by applying monadic computation to it
modifyMRefM ref f  =  readMRef ref >>= f >>= writeMRef ref

-- -----------------------------------------------------------------------------
-- Unboxed types list for compilers other that GHC

#ifndef __GLASGOW_HASKELL__
-- | Unboxed types
class Unboxed a
instance Unboxed Bool
instance Unboxed Char
instance Unboxed Int
instance Unboxed Int8
instance Unboxed Int16
instance Unboxed Int32
instance Unboxed Int64
instance Unboxed Word
instance Unboxed Word8
instance Unboxed Word16
instance Unboxed Word32
instance Unboxed Word64
instance Unboxed Float
instance Unboxed Double
instance Unboxed (Ptr a)
instance Unboxed (FunPtr a)
#endif

-- -----------------------------------------------------------------------------
-- Unboxed references in ST monad

-- | Create new unboxed reference in ST monad
newSTURef :: (Unboxed e) => e -> ST s (STURef s e)

-- | Read current value of unboxed reference in ST monad
readSTURef :: (Unboxed e) => STURef s e -> ST s e

-- | Change value of unboxed reference in ST monad
writeSTURef :: (Unboxed e) => STURef s e -> e -> ST s ()

#ifdef __GLASGOW_HASKELL__
-- | Unboxed references in ST monad
type STURef = URef
newSTURef = newURef
readSTURef = readURef
writeSTURef = writeURef
#else
-- | Unboxed references in ST monad
type STURef = STRef
newSTURef = newSTRef
readSTURef = readSTRef
writeSTURef = writeSTRef
#endif

-- -----------------------------------------------------------------------------
-- Unboxed references in IO monad

-- | Create new unboxed reference in IO monad
newIOURef :: (Unboxed e) => e -> IO (IOURef e)

-- | Read current value of unboxed reference in IO monad
readIOURef :: (Unboxed e) => IOURef e -> IO e

-- | Change value of unboxed reference in IO monad
writeIOURef :: (Unboxed e) => IOURef e -> e -> IO ()

#ifdef __GLASGOW_HASKELL__
-- | Unboxed references in IO monad
newtype IOURef a = IOURef (IOSpecific2 URef a)
newIOURef   a          = IOURef `liftM` newURef a
readIOURef  (IOURef r) = readURef r
writeIOURef (IOURef r) = writeURef r
#else
-- | Unboxed references in IO monad
type IOURef = IORef
newIOURef = newIORef
readIOURef = readIORef
writeIOURef = writeIORef
#endif

newPtr   a = newIOURef a
readPtr  a = readIOURef a
writePtr a = writeIOURef a

-- -----------------------------------------------------------------------------
-- FAST monad-neutral mutable variables

-- |A mutable in some monad 'm' variable of type 'r' holding values of unboxed type 'a'
--    (m->r restriction is needed to simplify using of newVar)
class (Monad m) => Var m r | m->r, r->m where
    -- |Build a new 'Var' with given initial value
    newVar   :: (Unboxed a) => a -> m (r a)
    -- |Read the value of an 'Var'
    readVar  :: (Unboxed a) => r a -> m a
    -- |Write a new value to an 'Var'
    writeVar :: (Unboxed a) => r a -> a -> m ()

instance Var IO IOURef where
    newVar = newIOURef
    readVar = readIOURef
    writeVar = writeIOURef

instance Var (ST s) (STURef s) where
    newVar = newSTURef
    readVar = readSTURef
    writeVar = writeSTURef

-- -----------------------------------------------------------------------------
-- Peek/poke bytes in memory

-- | Read byte from memory
readByteAt  :: Ptr a -> IO Int
-- | Write byte to memory
writeByteAt :: Ptr a -> Int -> IO ()

#ifdef __GLASGOW_HASKELL__

{-# INLINE readByteAt  #-}
readByteAt (Ptr addr#) = IO $ \s ->
  case readWord8OffAddr# addr# 0# s of { (# s, byte# #) ->
  (# s, I# (word2Int# byte#) #) }

{-# INLINE writeByteAt #-}
writeByteAt (Ptr addr#) (I# byte#) = IO $ \s ->
  case writeWord8OffAddr# addr# 0# (int2Word# byte#) s of { s ->
  (# s, () #) }

#else /* ! __GLASGOW_HASKELL__ */

readByteAt  ptr = do byte <- peek (castPtr ptr) :: IO Word8
                     return $! (fromIntegral byte)

writeByteAt ptr byte = poke (castPtr ptr) $! ((fromIntegral byte)::Word8)

#endif /* ! __GLASGOW_HASKELL__ */

-- -----------------------------------------------------------------------------
-- Fast Ints & Bools

#ifdef __GLASGOW_HASKELL__

type FastInt = Int#
_ILIT (I# x) = x
iBox x = I# x
iUnbox (I# x) = x
quotFastInt   = quotInt#
negateFastInt = negateInt#
(<<#)  = iShiftL#
(>>#)  = uncheckedIShiftRL#
a &# b = word2Int# (int2Word# a `and#` int2Word# b)
a |# b = word2Int# (int2Word# a `or#`  int2Word# b)

type FastBool = Int#
fastBool True  = 1#
fastBool False = 0#
isFastTrue x = x ==# 1#

fastOr 1# _ = 1#
fastOr 0# x = x

fastAnd 0# x = 0#
fastAnd 1# x = x

#else /* ! __GLASGOW_HASKELL__ */

type FastInt =  Int
_ILIT  x = x :: Int
iBox   x = x :: Int
iUnbox x = x :: Int
a+#b = a+b
a-#b = a-b
a*#b = a*b
a `quotFastInt`   b   = a `quot`   b
a `negateFastInt` b   = a `negate` b
a==#b = a==b
a<#b  = a<b
a<=#b = a<=b
a>=#b = a>=b
a>#b  = a>b
a<<#b = a `shiftL` b
a>>#b = a `shiftR` b
a&#b  = a.&.b
a|#b  = a.|.b

type FastBool = Bool
fastBool x = x
_IS_TRUE_ x = x

#endif /* ! __GLASGOW_HASKELL__ */