{-# LANGUAGE ScopedTypeVariables,RankNTypes, GADTs, CPP, EmptyDataDecls #-}
module Data.HKeyPrivate(
HKey(..)
, withKey
, T
, createKey
, unique
, KeyM
, KeyT
, Key
, runKey
, newKey
, getKey
, keyTSplit
, runKeyT) where
import Unsafe.Coerce
import Data.Unique
import System.IO.Unsafe
import Control.Monad
import Control.Applicative
import Control.Monad.Identity
import Control.Monad.Trans
import Control.Monad.Fix
import Data.Hashable
#if !(MIN_VERSION_hashable(1,2,4))
instance Hashable Unique where
hashWithSalt n u = n + hashUnique u
#endif
newtype HKey s a = Key Unique
withKey :: (forall x. HKey x a -> b) -> b
withKey f = unsafePerformIO $ liftM f createKey
{-# NOINLINE withKey #-}
data T
createKey :: IO (HKey T a)
createKey = fmap Key newUnique
unique :: HKey t a -> Unique
unique (Key u) = u
data GD s m a where
Lift :: m a -> GD s m a
GetKey :: GD s m (HKey s a)
Split :: KeyT s m a -> GD s m (m a)
GDFix :: MonadFix m => (a -> KeyT s m a) -> GD s m a
data TermM f a where
Return :: a -> TermM f a
Bind :: TermM f a -> (a -> TermM f b) -> TermM f b
Prim :: f a -> TermM f a
instance Monad (TermM f) where
return = Return
(>>=) = Bind
instance Functor (TermM f) where
fmap = liftM
instance Applicative (TermM f) where
pure = return
(<*>) = ap
type Bind f a v = (forall w. f w -> (w -> TermM f a) -> v)
interpret :: Bind f a v -> (a -> v) -> TermM f a -> v
interpret bind ret = int where
int (Return a) = ret a
int (Prim x) = bind x return
int (Bind (Prim x) f) = bind x f
int (Bind (Return x) f) = int (f x)
int (Bind (Bind p q) r) = int (Bind p (\x -> Bind (q x) r))
type KeyM s a = KeyT s Identity a
newtype KeyT s m a = KeyT { getKT :: TermM (GD s m) a }
instance Monad m => Functor (KeyT s m) where
fmap f m = m >>= return . f
instance Monad m => Applicative (KeyT s m) where
pure = return
f <*> x = do fv <- keyTSplit f; xv <- keyTSplit x; lift (ap fv xv)
instance Monad m => Monad (KeyT s m) where
return = KeyT . Return
c >>= f = KeyT $ getKT c >>= getKT . f
instance MonadFix m => MonadFix (KeyT s m) where
mfix m = KeyT $ Bind (Prim (GDFix m)) Return
newKey :: KeyT s m (HKey s a)
newKey = getKey
getKey :: KeyT s m (HKey s a)
getKey = KeyT $ Bind (Prim GetKey) Return
#if __GLASGOW_HASKELL__ >= 700
{-# INLINABLE getKey #-}
#endif
keyTSplit :: KeyT s m a -> KeyT s m (m a)
keyTSplit m = KeyT $ Bind (Prim (Split m)) Return
instance MonadTrans (KeyT s) where
lift m = KeyT (Prim (Lift m))
type Key s = KeyT s Identity
runKey :: (forall s. Key s a) -> a
runKey m = runIdentity (runKeyT m)
runKeyT :: forall m a. Monad m => (forall s. KeyT s m a) -> m a
runKeyT (KeyT m) = loop m where
loop :: TermM (GD T m) b -> m b
loop = interpret bind return where
{-# NOINLINE bind #-}
bind :: Bind (GD T m) x (m x)
bind (Lift m) c = m >>= loop . c
bind GetKey c = unsafePerformIO (liftM (loop . c) createKey)
bind (Split (KeyT m)) c = loop $ c $ loop m
bind (GDFix f) c = mfix (loop . getKT . f) >>= loop . c