New MonadRef type class and pure instance

glyph.cabal

@@ -24,6 +24,7 @@ executable glyph
     syb,
     template-haskell,
     text,
+    transformers,
     hoopl,
     wl-pprint-extras,
     deepseq

src/Control/Monad/Ref.hs

@@ -0,0 +1,13 @@
+module Control.Monad.Ref
+       ( MonadRef (..)
+       , RefSupply
+       , runRefSupply
+       , RefSupplyT
+       , runRefSupplyT
+       , module X
+       ) where
+
+import Control.Monad as X
+import Control.Monad.Ref.Class
+import Control.Monad.Trans as X
+import Control.Monad.Trans.Ref

src/Control/Monad/Ref/Class.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE
+    FlexibleInstances
+  , FunctionalDependencies
+  , MultiParamTypeClasses
+  , UndecidableInstances #-}
+module Control.Monad.Ref.Class
+       ( MonadRef (..)
+       ) where
+
+import Control.Monad.ST
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Error
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Ref hiding (modifyRef, newRef, readRef, writeRef)
+import qualified Control.Monad.Trans.Ref as Ref
+import Control.Monad.Trans.Writer.Lazy as Lazy
+import Control.Monad.Trans.Writer.Strict as Strict
+
+import Data.IORef
+import Data.Monoid
+import Data.STRef
+
+class Monad m => MonadRef r m | m -> r where
+  newRef :: a -> m (r a)
+  readRef :: r a -> m a
+  writeRef :: r a -> a -> m ()
+  modifyRef :: r a -> (a -> a) -> m ()
+  modifyRef r f = do
+    a <- readRef r
+    writeRef r (f a)
+
+instance Monad m => MonadRef (Ref s) (RefSupplyT s m) where
+  newRef = Ref.newRef
+  readRef = Ref.readRef
+  writeRef = Ref.writeRef
+  modifyRef = Ref.modifyRef
+
+instance MonadRef IORef IO where
+  newRef = newIORef
+  readRef = readIORef
+  writeRef = writeIORef
+  modifyRef = modifyIORef
+
+instance MonadRef (STRef s) (ST s) where
+  newRef = newSTRef
+  readRef = readSTRef
+  writeRef = writeSTRef
+  modifyRef = modifySTRef
+
+instance (Error e, MonadRef r m) => MonadRef r (ErrorT e m) where
+  newRef = lift . newRef
+  readRef = lift . readRef
+  writeRef r = lift . writeRef r
+  modifyRef r = lift . modifyRef r
+
+instance MonadRef r' m => MonadRef r' (ReaderT r m) where
+  newRef = lift . newRef
+  readRef = lift . readRef
+  writeRef r = lift . writeRef r
+  modifyRef r = lift . modifyRef r
+
+instance (Monoid w, MonadRef r m) => MonadRef r (Lazy.WriterT w m) where
+  newRef = lift . newRef
+  readRef = lift . readRef
+  writeRef r = lift . writeRef r
+  modifyRef r = lift . modifyRef r
+
+instance (Monoid w, MonadRef r m) => MonadRef r (Strict.WriterT w m) where
+  newRef = lift . newRef
+  readRef = lift . readRef
+  writeRef r = lift . writeRef r
+  modifyRef r = lift . modifyRef r

src/Control/Monad/Trans/Ref.hs

@@ -0,0 +1,139 @@
+{-# LANGUAGE
+    FlexibleInstances
+  , MultiParamTypeClasses
+  , Rank2Types
+  , UndecidableInstances #-}
+module Control.Monad.Trans.Ref
+       ( RefSupply
+       , runRefSupply
+       , RefSupplyT
+       , runRefSupplyT
+       , Ref
+       , newRef
+       , readRef
+       , writeRef
+       , modifyRef
+       ) where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Fix
+import Control.Monad.IO.Class
+import Control.Monad.Reader.Class
+import Control.Monad.Trans.Class
+import Control.Monad.Writer.Class
+
+import Data.Functor.Identity
+import Data.IntMap (IntMap, Key, (!))
+import qualified Data.IntMap as IntMap
+
+import GHC.Exts (Any)
+
+import qualified Unsafe.Coerce as Unsafe (unsafeCoerce)
+
+type RefSupply s = RefSupplyT s Identity
+
+runRefSupply :: (forall s . RefSupply s a) -> a
+runRefSupply = runIdentity . runRefSupplyT
+
+newtype RefSupplyT s m a =
+  RefSupplyT { unRefSupplyT :: S -> m (PairS a)
+             }
+
+runRefSupplyT :: Monad m => (forall s . RefSupplyT s m a) -> m a
+runRefSupplyT m = do
+  PairS a _ <- unRefSupplyT m initS
+  return a
+
+get :: Monad m => RefSupplyT s m S
+get = RefSupplyT $ \ s -> return $! PairS s s
+
+put :: Monad m => S -> RefSupplyT s m ()
+put s = RefSupplyT $ \ _ -> return $! PairS () s
+
+modify :: Monad m => (S -> S) -> RefSupplyT s m ()
+modify f = RefSupplyT $ \ s -> return $! PairS () (f s)
+
+instance Functor m => Functor (RefSupplyT s m) where
+  fmap f m = RefSupplyT $ \ s -> fmap (fmap f) $ unRefSupplyT m s
+
+instance (Functor m, MonadPlus m) => Alternative (RefSupplyT s m) where
+  empty = mzero
+  (<|>) = mplus
+
+instance (Functor m, Monad m) => Applicative (RefSupplyT s m) where
+  pure a = RefSupplyT $ \ s -> return $! PairS a s
+  (<*>) = ap
+
+instance Monad m => Monad (RefSupplyT s m) where
+  return a = RefSupplyT $ \ s -> return $! PairS a s
+  m >>= k = RefSupplyT $ \ s -> do
+    PairS a s' <- unRefSupplyT m s
+    unRefSupplyT (k a) s'
+
+instance MonadPlus m => MonadPlus (RefSupplyT s m) where
+  mzero = RefSupplyT $ \ _ -> mzero
+  m `mplus` n = RefSupplyT $ \ s -> unRefSupplyT m s `mplus` unRefSupplyT n s
+
+instance MonadFix m => MonadFix (RefSupplyT s m) where
+  mfix f = RefSupplyT $ \ s -> mfix $ \ ~(PairS a _) -> unRefSupplyT (f a) s
+
+instance MonadTrans (RefSupplyT s) where
+  lift m = RefSupplyT $ \ s -> do
+    a <- m
+    return $! PairS a s
+
+instance MonadIO m => MonadIO (RefSupplyT s m) where
+  liftIO = lift . liftIO
+
+instance MonadReader r m => MonadReader r (RefSupplyT s m) where
+  ask = lift ask
+  local = undefined
+  reader = lift . reader
+
+instance MonadWriter w m => MonadWriter w (RefSupplyT s m) where
+  writer = lift . writer
+  tell = lift . tell
+  listen = undefined
+  pass = undefined
+
+data PairS a = PairS a !S
+
+instance Functor PairS where
+  fmap f (PairS a s) = PairS (f a) s
+
+data S = S !Key !(IntMap Value)
+
+newtype Value = Value { unValue :: Any }
+
+initS :: S
+initS = S minBound IntMap.empty
+
+newtype Ref s a = Ref Key
+
+newRef :: Monad m => a -> RefSupplyT s m (Ref s a)
+newRef v = do
+  S n m <- get
+  put $! S (n + 1) (IntMap.insert n (toValue v) m)
+  return $! Ref n
+
+readRef :: Monad m => Ref s a -> RefSupplyT s m a
+readRef (Ref k) = do
+  S _ m <- get
+  return $ fromValue $ m!k
+
+writeRef :: Monad m => Ref s a -> a -> RefSupplyT s m ()
+writeRef (Ref k) v =
+  modify $ \ (S n m) -> S n $ IntMap.insert k (toValue v) m
+
+modifyRef :: Monad m => Ref s a -> (a -> a) -> RefSupplyT s m ()
+modifyRef (Ref k) f =
+  modify $ \ (S n m) -> S n $ IntMap.adjust f' k m
+  where
+    f' = toValue . f . fromValue
+
+toValue :: v -> Value
+toValue = Value . Unsafe.unsafeCoerce
+
+fromValue :: Value -> v
+fromValue = Unsafe.unsafeCoerce . unValue

src/Language/Glyph/HM/InferType.hs

@@ -22,6 +22,7 @@ import Control.DeepSeq
 import Control.Exception
 import Control.Monad.Error hiding (forM, forM_)
 import Control.Monad.Reader hiding (forM, forM_)
+import Control.Monad.Ref hiding (forM, forM_)
 import Control.Monad.ST
 
 import Data.Foldable (foldr, forM_, toList)
@@ -247,7 +248,6 @@ modify' f = do
   s <- get
   put $! f s
 
-type Normalize a s = ErrorT TypeException (ReaderT a (WriterT Msgs (ST s)))
 type Ref = STRef
 
 data Normalized = Normalized !(Constraint Normal) !Substitution
@@ -265,19 +265,13 @@ normalize = runNormalize
   where
     runNormalize d =
       run (normalizeM' d mempty)
-    normalizeM' :: Constraint Nonnormal ->
-                   Substitution ->
-                   Normalize a s Normalized
     normalizeM' d phi = do
       d' <- newRef d
       phi' <- newRef phi
       normalizeM d' phi'
-    normalizeM :: Ref s (Constraint Nonnormal) ->
-                  Ref s Substitution ->
-                  Normalize a s Normalized
     normalizeM d psi = do
       c <- newRef mempty
-      whileJust (uncons <$> readRef d) $ \ (p, d') -> do
+      whileJust (liftM uncons $ readRef d) $ \ (p, d') -> do
         writeRef d d'
         case p of
           tau := tau' -> do
@@ -322,7 +316,7 @@ normalize = runNormalize
             tellMissingLabel tau l
           tau@(Cont _) `Has` (l, _) ->
             tellMissingLabel tau l
-      Normalized <$> readRef c <*> readRef psi
+      liftM2 Normalized (readRef c) (readRef psi)
     (d `forAll` (a, l)) f =
       forRefM_ d $ \ p ->
         case p of
@@ -333,17 +327,8 @@ normalize = runNormalize
     forRefM_ ref f = do
       x <- readRef ref
       forM_ x f
-    run :: (forall s . Normalize a s Normalized) ->
-           m Normalized
-    run m = do
-      r <- ask
-      let (a, w) = runST (runWriterT (runReaderT (runErrorT m) r))
-      tell w
-      either throwError return a
-    newRef = lift . lift . lift . newSTRef
-    readRef = lift . lift . lift . readSTRef
-    modifyRef r = lift . lift . lift . modifySTRef r
-    writeRef r = lift . lift . lift . writeSTRef r
+    run :: (forall s . RefSupplyT s m Normalized) -> m Normalized
+    run m = runRefSupplyT m
     u = flip Set.insert
     (\\) = flip Set.delete
     uncons xs = go . toList $ xs

src/Language/Glyph/Writer/Strict.hs

@@ -1,4 +1,7 @@
-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE
+    FlexibleInstances
+  , MultiParamTypeClasses
+  , UndecidableInstances #-}
 module Language.Glyph.Writer.Strict
        ( module X
        , WriterT
@@ -9,6 +12,7 @@ import Compiler.Hoopl
 import Control.Applicative
 import Control.Monad as X
 import Control.Monad.Fix as X
+import Control.Monad.Ref.Class
 import Control.Monad.Trans as X
 import Control.Monad.Writer.Class as X
 
@@ -63,5 +67,11 @@ instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where
     Pair (a, f) w <- unWriterT m
     return $! Pair a (f w)
 
+instance (Monoid w, MonadRef r m) => MonadRef r (WriterT w m) where
+  newRef = lift . newRef
+  readRef = lift . readRef
+  writeRef r = lift . writeRef r
+  modifyRef r = lift . modifyRef r
+
 instance (Monoid w, UniqueMonad m) => UniqueMonad (WriterT w m) where
   freshUnique = lift freshUnique