Operators.hs

-----------------------------------------------------------
-- |
-- Module      : Control.Imperative.Operators
-- Copyright   : (C) 2015, Yu Fukuzawa
-- License     : BSD3
-- Maintainer  : minpou.primer@email.com
-- Stability   : experimental
-- Portability : portable
--
-----------------------------------------------------------

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Control.Imperative.Operators
( -- * Operators
  liftOp
, liftOp2
, (~$), (~*)
  -- *** Binary Operation
, (/.), (%.), (^.), (&&.), (||.)
, (==.), (/=.), (>=.), (<=.), (>.), (<.), notR, (&.), (|.), xorR, complR, (<<.), (>>.)
  -- *** Assignment Operators
, assignModify
, (=:), (+=:), (-=:), (*=:), (/=:), (%=:), (^=:), (//=:), (**=:), (<>=:)
, (&&=:), (||=:), (&=:), (|=:), (<<=:), (>>=:)
, (<~), (<&~)
) where
import           Control.Imperative.Internal
import           Control.Monad.Base
import           Data.Bits
import           Data.Monoid

-- | Alias for 'liftOp'.
(~$) :: Monad m => (a -> b) -> Ref m a -> Ref m b
(~$) = liftOp
{-# INLINE (~$) #-}

-- | Analogous to (\<*\>) for Applicative.
(~*) :: Monad m => Ref m (a -> b) -> Ref m a -> Ref m b
(~*) = liftOp2 ($)
{-# INLINE (~*) #-}

infixl 4 ~$, ~*

(/.), (%.) :: Monad m => Integral a => Ref m a -> Ref m a -> Ref m a
(/.) = liftOp2 div
{-# INLINE (/.) #-}
(%.) = liftOp2 mod
{-# INLINE (%.) #-}

infixl 7 /., %.

(^.) :: (Num a, Integral b, Monad m) => Ref m a -> Ref m b -> Ref m a
(^.) = liftOp2 (^)
{-# INLINE (^.) #-}

infixr 8 ^.

(&&.), (||.) :: Monad m => Ref m Bool -> Ref m Bool -> Ref m Bool
(&&.) = liftOp2 (&&)
{-# INLINE (&&.) #-}
(||.) = liftOp2 (||)
{-# INLINE (||.) #-}

infixr 3 &&.
infixr 2 ||.

(==.), (/=.), (>=.), (<=.), (<.), (>.) :: (Ord a, Monad m) => Ref m a -> Ref m a -> Ref m Bool
(==.) = liftOp2 (==)
{-# INLINE (==.) #-}
(/=.) = liftOp2 (/=)
{-# INLINE (/=.) #-}
(>=.) = liftOp2 (>=)
{-# INLINE (>=.) #-}
(<=.) = liftOp2 (<=)
{-# INLINE (<=.) #-}
(>.)  = liftOp2 (>)
{-# INLINE (>.) #-}
(<.)  = liftOp2 (<)
{-# INLINE (<.) #-}

infixl 4 ==., /=., >=., <=., <., >.

notR :: Monad m => Ref m Bool -> Ref m Bool
notR = liftOp not
{-# INLINE notR #-}

(&.), (|.), xorR :: (Bits a, Monad m) => Ref m a -> Ref m a -> Ref m a
(&.) = liftOp2 (.&.)
{-# INLINE (&.) #-}
(|.) = liftOp2 (.|.)
{-# INLINE (|.) #-}
xorR = liftOp2 xor
{-# INLINE xorR #-}

infixl 7 &.
infixl 5 |.

(<<.), (>>.) :: (Bits a, Monad m) => Ref m a -> Ref m Int -> Ref m a
(<<.) = liftOp2 shiftL
{-# INLINE (<<.) #-}
(>>.) = liftOp2 shiftR
{-# INLINE (>>.) #-}

infixl 5 <<., >>.

complR :: (Bits a, Monad m) => Ref m a -> Ref m a
complR = liftOp complement
{-# INLINE complR #-}

-- | Modify the value of mutable 'Ref' with another 'Ref'.
assignModify :: MonadBase (BaseEff m) m => (a -> b -> a) -> Ref (BaseEff m) a -> Ref (BaseEff m) b -> m ()
assignModify f v w = ref (liftOp2 f v w) >>= assign v
{-# INLINE assignModify #-}

-- | An assignment operator.
(=:) :: MonadBase (BaseEff m) m => Ref (BaseEff m) a -> Ref (BaseEff m) a -> m ()
(=:) v w = ref w >>= assign v
{-# INLINE (=:) #-}

(+=:), (-=:), (*=:) :: (Num a, MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> Ref (BaseEff m) a -> m ()
(+=:) = assignModify (+)
{-# INLINE (+=:) #-}
(-=:) = assignModify (-)
{-# INLINE (-=:) #-}
(*=:) = assignModify (*)
{-# INLINE (*=:) #-}

(/=:), (%=:) :: (Integral a, MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> Ref (BaseEff m) a -> m ()
(/=:) = assignModify div
{-# INLINE (/=:) #-}
(%=:) = assignModify mod
{-# INLINE (%=:) #-}

(^=:) :: (Num a, Integral b, MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> Ref (BaseEff m) b -> m ()
(^=:) = assignModify (^)
{-# INLINE (^=:) #-}

(//=:) :: (Fractional a, MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> Ref (BaseEff m) a -> m ()
(//=:) = assignModify (/)
{-# INLINE (//=:) #-}

(**=:) :: (Floating a, MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> Ref (BaseEff m) a -> m ()
(**=:) = assignModify (**)
{-# INLINE (**=:) #-}

(&=:), (|=:) :: (Bits a, MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> Ref (BaseEff m) a -> m ()
(&=:) = assignModify (.&.)
{-# INLINE (&=:) #-}
(|=:) = assignModify (.|.)
{-# INLINE (|=:) #-}

(<<=:), (>>=:) :: (Bits a, MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> Ref (BaseEff m) Int -> m ()
(<<=:) = assignModify shiftL
{-# INLINE (<<=:) #-}
(>>=:) = assignModify shiftR
{-# INLINE (>>=:) #-}

(<>=:) :: (Monoid a, MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> Ref (BaseEff m) a -> m ()
(<>=:) = assignModify (<>)
{-# INLINE (<>=:) #-}

(&&=:), (||=:) :: MonadBase (BaseEff m) m => Ref (BaseEff m) Bool -> Ref (BaseEff m) Bool -> m ()
(&&=:) = assignModify (&&)
{-# INLINE (&&=:) #-}
(||=:) = assignModify (||)
{-# INLINE (||=:) #-}

-- | Run a monadic action, and assign the result of it to the mutable 'Ref'.
(<~) :: MonadBase (BaseEff m) m => Ref (BaseEff m) a -> m a -> m ()
v <~ m = m >>= assign v
{-# INLINE (<~) #-}

-- | Modify the mutable 'Ref' with an endomorphism.
(<&~) :: MonadBase (BaseEff m) m => Ref (BaseEff m) a -> (a -> a) -> m ()
v <&~ f = ref v >>= assign v . f
{-# INLINE (<&~) #-}

infix 2 =:, +=:, -=:, *=:, %=:, /=:, ^=:, //=:, **=:
infix 2 &&=:, ||=:, &=:, |=:, <<=:, >>=:, <>=:
infixr 2 <~
infix 2 <&~