-- copied (and minimally adapted) from strict-identity-0.1.0.0
-- which apparently has been abandoned
{- |
Module      :  Control.Monad.StrictIdentity
Copyright   :  (c) Carter Schonwald 2013
License     :  BSD3, see license file
 
Maintainer  :  libraries@haskell.org
Stability   :  experimental
Portability :  portable
-}
{-# LANGUAGE BangPatterns #-}
 
module Darcs.Util.StrictIdentity (
    StrictIdentity(..),
    runStrictIdentity)
    where
 
import Darcs.Prelude
import Control.Monad.Fix 


{- | 'StrictIdentity' is a newtype wrapper for a given type 'a' that 
satisfies the 'Functor', 'Applicative', and 'Monad' laws  when restricted to
terminating strict computations. 

The typical use case is to provide a light weight strict nested 
let notation for code that otherwise must use nested case expressions
as a proxy for a strict let.

the general pattern is to write code of the form

@
foo f h g x y z = runStrictIdentity $! do
    w <- return $! f x y
    j <- return $! h w z
    res <- return $! g w j
    return res
@

An example usage of 'StrictIdentity' that compiles to assembly 
comparable to C is the following:

@
(>>) = unsafeShiftR
(<<) = unsafeShiftL
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
@


-}
 
newtype StrictIdentity a =  StrictIdentity {forall a. StrictIdentity a -> a
runStrictIdentity_ :: a }
 
-- | 'runStrictIdentity' unwraps a value of type  @'StrictIdentity' ty@  into a value of type @ty@,  strictly.
runStrictIdentity :: StrictIdentity a -> a 
runStrictIdentity :: forall a. StrictIdentity a -> a
runStrictIdentity !StrictIdentity a
ma = case StrictIdentity a -> a
forall a. StrictIdentity a -> a
runStrictIdentity_ (StrictIdentity a -> a) -> StrictIdentity a -> a
forall a b. (a -> b) -> a -> b
$! StrictIdentity a
ma of 
                            !a
res -> a
res  
{-# INLINE  runStrictIdentity #-} 


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

instance Functor StrictIdentity where
    {-# INLINE fmap  #-}
    fmap :: forall a b. (a -> b) -> StrictIdentity a -> StrictIdentity b
fmap !a -> b
f !StrictIdentity a
m = b -> StrictIdentity b
forall a. a -> StrictIdentity a
StrictIdentity (b -> StrictIdentity b) -> b -> StrictIdentity b
forall a b. (a -> b) -> a -> b
$! (a -> b
f (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$! (StrictIdentity a -> a
forall a. StrictIdentity a -> a
runStrictIdentity StrictIdentity a
m))
 
instance Monad StrictIdentity where
    {-# INLINE return  #-}
    return :: forall a. a -> StrictIdentity a
return = a -> StrictIdentity a
forall a. a -> StrictIdentity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    {-# INLINE  (>>=) #-}
    (!StrictIdentity a
m) >>= :: forall a b.
StrictIdentity a -> (a -> StrictIdentity b) -> StrictIdentity b
>>= (!a -> StrictIdentity b
k)  = a -> StrictIdentity b
k (a -> StrictIdentity b) -> a -> StrictIdentity b
forall a b. (a -> b) -> a -> b
$! StrictIdentity a -> a
forall a. StrictIdentity a -> a
runStrictIdentity  StrictIdentity a
m    
 --StrictIdentity m >>= k  =  k $! m
instance MonadFix StrictIdentity where
    {-# INLINE mfix  #-}
    mfix :: forall a. (a -> StrictIdentity a) -> StrictIdentity a
mfix !a -> StrictIdentity a
f = a -> StrictIdentity a
forall a. a -> StrictIdentity a
StrictIdentity (a -> StrictIdentity a) -> a -> StrictIdentity a
forall a b. (a -> b) -> a -> b
$! ((a -> a) -> a
forall a. (a -> a) -> a
fix  (StrictIdentity a -> a
forall a. StrictIdentity a -> a
runStrictIdentity (StrictIdentity a -> a) -> (a -> StrictIdentity a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> StrictIdentity a
f))