X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FState.hs;h=578a7b3665a9c43589c5c6097c70587337e3ad14;hb=1a7d1b77334529ca96ed4cbc03fcb5f55dc2de4a;hp=faed566e3e01734b0e8be3237c7aa0d7bd8a78e5;hpb=0f7d268d00795a58a06ae3c92ebbd14571295b84;p=ghc-hetmet.git

diff --git a/compiler/utils/State.hs b/compiler/utils/State.hs
index faed566..578a7b3 100644
--- a/compiler/utils/State.hs
+++ b/compiler/utils/State.hs
@@ -1,31 +1,63 @@
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
 
 module State where
 
 newtype State s a
 	= State
-	{ runState :: s -> (# a, s #) }
+	{ runState' :: s -> (# a, s #) }
 
 instance Monad (State s) where
     return x	= State $ \s -> (# x, s #)
     m >>= n	= State $ \s ->
-    			case runState m s of
-			  (# r, s' #)	-> runState (n r) s'
+    			case runState' m s of
+			  (# r, s' #)	-> runState' (n r) s'
 
 get ::	State s s
 get	= State $ \s -> (# s, s #)
 
+gets :: (s -> a) -> State s a
+gets f 	= State $ \s -> (# f s, s #)
+
 put :: 	s -> State s ()
 put s'	= State $ \s -> (# (), s' #)
 
 modify :: (s -> s) -> State s ()
 modify f = State $ \s -> (# (), f s #)
 
+
 evalState :: State s a -> s -> a
 evalState s i
-	= case runState s i of
+	= case runState' s i of
 		(# a, s' #)	-> a
 
+
 execState :: State s a -> s -> s
 execState s i
-	= case runState s i of
+	= case runState' s i of
 		(# a, s' #) 	-> s'
+
+
+runState :: State s a -> s -> (a, s)
+runState s i
+	= case runState' s i of
+		(# a, s' #)	-> (a, s')
+
+
+mapAccumLM
+	:: Monad m
+	=> (acc -> x -> m (acc, y))	-- ^ combining funcction
+	-> acc				-- ^ initial state
+	-> [x]				-- ^ inputs
+	-> m (acc, [y])			-- ^ final state, outputs
+
+mapAccumLM _ s []	= return (s, [])
+mapAccumLM f s (x:xs)
+ = do
+	(s1, x')	<- f s x
+	(s2, xs')	<- mapAccumLM f s1 xs
+	return		(s2, x' : xs')