strict identity monad and example

OuterShuffle.hs

import Data.Bits
import Data.Word
import Prelude hiding ((>>)) 
import Data.List (foldl')
import Data.Typeable
import Data.Data 
import Control.Monad.StrictIdentity hiding ((>>))



infixl 8  << , >>
(<<):: Bits a=> a ->Int -> a
(<<) = unsafeShiftL
{-# INLINE (<<) #-}

(>>)::  Bits a=> a ->Int -> a
(>>) = unsafeShiftR
{-# INLINE (>>) #-}


outerShuffle64A :: Word -> Word 
outerShuffle64A !x =
    runStrictIdentity $! do

        x <- return $! ((x .&. 0x00000000FFFF0000) << 16 )
            .|. ((x>>16) .&. 0x00000000FFFF0000) .|. (x .&. 0xFFFF00000000FFFF)
        x <-  return $! ((x .&. 0x0000FF000000FF00 ) <<  8 )
            .|. (x >> 8) .&. 0x0000FF000000FF00 .|. (x  .&. 0xFF0000FFFF0000FF)
        x<-  return $! (( x .&. 0x00F000F000F000F0 ) << 4 )
            .|. (x >> 4) .&. 0x00F000F000F000F0 .|. (x .&. 0xF00FF00FF00FF00F )
        x<-   return $!((x .&.  0x0C0C0C0C0C0C0C0C )<< 2 )
            .|. (x >> 2) .&. 0x0C0C0C0C0C0C0C0C .|.( x .&. 0xC3C3C3C3C3C3C3C3)
        x<-   return $! ( (x .&. 0x2222222222222222)  << 1 ) 
            .|. (x>> 1) .&. 0x2222222222222222 .|. (x .&. 0x9999999999999999)
        return x
{-# INLINE outerShuffle64A #-}  

StrictIdentity.hs

{- |
Module      :  Control.Monad.Strict
Copyright   :  (c) Carter Schonwald 2013
License     :  BSD3, see license file

Maintainer  :  [email protected]
Stability   :  experimental
Portability :  portable
-}
{-# LANGUAGE BangPatterns #-}


module Control.Monad.StrictIdentity (
    StrictIdentity(..),
    runStrictIdentity,
    module Control.Monad,
    module Control.Monad.Fix )
    where

import Control.Monad
import Control.Monad.Fix 
import Control.Applicative

newtype StrictIdentity a =  StrictIdentity {runStrictIdentity_ :: a }

{-# INLINE  runStrictIdentity #-}
runStrictIdentity :: StrictIdentity a -> a 
runStrictIdentity !ma = case runStrictIdentity_ $! ma of 
                            !res -> res  

instance Applicative StrictIdentity where
    {-# INLINE pure #-}
    pure = return 
    {-# INLINE (<*>) #-}
    (<*>) a b = do   f <- a ; v <- b ; return $! (f $! v)
    -- ap a b = liftM2 id a b  =  do  f <- a ; v<- b ; return ((id) )

instance Functor StrictIdentity where
    {-# INLINE fmap  #-}
    fmap !f !m = StrictIdentity $! (f $! (runStrictIdentity m))

instance Monad StrictIdentity where
    {-# INLINE return  #-}
    return !a = StrictIdentity $! a
    {-# INLINE  (>>=) #-}
    (!m) >>= (!k)  = k $! (runStrictIdentity $! m)    

instance MonadFix StrictIdentity where
    {-# INLINE mfix  #-}
    mfix !f = StrictIdentity $! (fix  (runStrictIdentity . f))