-- The HiPar Toolkit: state transformer routines -- -- Author : Manuel M. T. Chakravarty -- Created: 3 March 95 -- -- Version $Revision: 1.1.1.1 $ from $Date: 2004/11/13 16:42:45 $ -- -- Copyright (C) [1995..1999] Manuel M. T. Chakravarty -- -- This file is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This file is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- --- DESCRIPTION --------------------------------------------------------------- -- -- This module provides basic support for the use of state transformers. -- The state transformer is build around the `IO' monad to allow the -- manipulation of external state. It encapsulated two separate states with -- the intention to use the first one for the omnipresent compiler state -- consisting of the accumulated error messages etc. and to use the second as -- a generic component that can be used in different ways by the different -- phases of the compiler. -- -- The module also supports the use of exceptions and fatal errors. -- --- DOCU ---------------------------------------------------------------------- -- -- language: Haskell 98 -- -- * We explicitly do not use any names for the monad types and functions -- that are used by either Haskell's `IO' monad or GHC's `ST' monad. Since -- Haskell 1.4, `STB' is an instance of the `Monad' constructor class. -- -- * To integrate the Haskell prelude `IO' monad into our `STB' monad we use -- the technique from ``Composing monads'' by Mark P. Jones and Luc -- Duponcheel (Report YALEU/DCS/RR-1004) from 1993, Section 8. -- -- * The use of GHC's inplace-update goodies within monads of kind `STB' is -- possible, bacause `IO' is based on `ST' in the GHC. -- -- * In the following, we call the two kinds of state managed by the `STB' the -- base state (the omnipresent state of the compiler) and generic state. -- -- * `STB' is a newtype, which requires careful wrapping and unwrapping of its -- values in the following definitions. -- --- TODO ---------------------------------------------------------------------- -- -- * with constructor classes, the state transformer business can be made -- more elegant (they weren't around when this module was initially written) -- -- * it would be possible to maintain the already applied changes to the base -- and generic state even in the case of a fatal error, when in `listIO' -- every IO operation is encapsulated into a handler that transforms IO -- errors into exceptions -- module StateTrans (-- the monad and the generic operations -- STB, fixSTB, -- -- monad specific operations -- readBase, writeBase, transBase, readGeneric, writeGeneric, transGeneric, liftIO, runSTB, interleave, -- -- exception handling and fatal errors -- throwExc, fatal, catchExc, fatalsHandledBy, -- -- mutable variables and arrays -- MVar, newMV, readMV, assignMV) where import Prelude hiding (catch) import Control.Applicative (Applicative(..)) import Control.Monad (liftM, ap) import Control.Exception (catch) import System.IO (fixIO) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Errors (interr) infixr 1 +>=, +> -- BEWARE! You enter monad country. Read any of Wadler's or -- Launchbury/Peyton-Jones' texts before entering. Otherwise, -- your mental health my be in danger. You have been warned! -- state transformer base and its monad operations -- ----------------------------------------------- -- the generic form of a state transformer using the external state represented -- by `IO'; `STB' is a abbreviation for state transformer base -- -- the first state component `bs' is provided for the omnipresent compiler -- state and the, second, `gs' for the generic component -- -- the third component of the result distinguishes between erroneous and -- successful computations where -- -- `Left (tag, msg)' -- stands for an exception identified by `tag' with -- error message `msg', and -- `Right a' -- is a successfully delivered result -- newtype STB bs gs a = STB (bs -> gs -> IO (bs, gs, Either (String, String) a)) instance Functor (STB bs gs) where fmap = liftM instance Applicative (STB bs gs) where pure = return (<*>) = ap instance Monad (STB bs gs) where return = yield (>>=) = (+>=) (>>) = (+>) -- the monad's unit -- yield :: a -> STB bs gs a yield a = STB $ \bs gs -> return (bs, gs, Right a) -- the monad's bind -- -- * exceptions are propagated -- (+>=) :: STB bs gs a -> (a -> STB bs gs b) -> STB bs gs b m +>= k = let STB m' = m in STB $ \bs gs -> m' bs gs >>= \(bs', gs', res) -> case res of Left exc -> return (bs', gs', Left exc) -- prop exc Right a -> let STB k' = k a in k' bs' gs' -- cont -- bind dropping the result of the first state transfomer -- (+>) :: STB bs gs a -> STB bs gs b -> STB bs gs b k +> m = k +>= const m -- fixpoint combinator in the monad -- fixSTB :: (a -> STB bs gs a) -> STB bs gs a -- -- builds on the fixpoint combinator embedded within the IO monad; the -- future overall result wrapped into a closure with the function extracting -- the user-level result component is used to build the cycle -- fixSTB m = STB $ \bs gs -> fixIO (\future -> let STB m' = m (extractResult future) in m' bs gs) where extractResult (_, _, Right r) = r extractResult (_, _, Left _ ) = interr "StateTrans: fixSTB: \ \Tried to access result \ \of unsuccessful \ \recursive computation!" -- generic state manipulation -- -------------------------- -- base state: -- -- given a reader function for the base state, wrap it into an STB monad -- readBase :: (bs -> a) -> STB bs gs a readBase f = STB $ \bs gs -> return (bs, gs, Right (f bs)) -- given a new base state, inject it into an STB monad -- writeBase :: bs -> STB bs gs () writeBase bs' = STB $ \_ gs -> return (bs', gs, Right ()) -- given a transformer function for the base state, wrap it into an STB monad -- transBase :: (bs -> (bs, a)) -> STB bs gs a transBase f = STB $ \bs gs -> let (bs', a) = f bs in return (bs', gs, Right a) -- generic state: -- -- given a reader function for the generic state, wrap it into an STB monad -- readGeneric :: (gs -> a) -> STB bs gs a readGeneric f = STB $ \bs gs -> return (bs, gs, Right (f gs)) -- given a new generic state, inject it into an STB monad -- writeGeneric :: gs -> STB bs gs () writeGeneric gs' = STB $ \bs _ -> return (bs, gs', Right ()) -- given a transformer function for the generic state, wrap it into an STB -- monad -- transGeneric :: (gs -> (gs, a)) -> STB bs gs a transGeneric f = STB $ \bs gs -> let (gs', a) = f gs in return (bs, gs', Right a) -- interaction with the encapsulated `IO' monad -- -------------------------------------------- -- lifts an `IO' state transformer into `STB' -- liftIO :: IO a -> STB bs gs a liftIO m = STB $ \bs gs -> m >>= \r -> return (bs, gs, Right r) -- given an initial state, executes the `STB' state transformer yielding an -- `IO' state transformer that must be placed into the context of the external -- IO -- -- * uncaught exceptions become fatal errors -- runSTB :: STB bs gs a -> bs -> gs -> IO a runSTB m bs gs = let STB m' = m in m' bs gs >>= \(_, _, res) -> case res of Left (tag, msg) -> let err = userError ("Exception `" ++ tag ++ "': " ++ msg) in ioError err Right a -> return a -- interleave the (complete) execution of an `STB' with another generic state -- component into an `STB' -- interleave :: STB bs gs' a -> gs' -> STB bs gs a interleave m gs' = STB $ let STB m' = m in \bs gs -> (m' bs gs' >>= \(bs', _, a) -> return (bs', gs, a)) -- error and exception handling -- ---------------------------- -- * we exploit the `UserError' component of `IOError' for fatal errors -- -- * we distinguish exceptions and user-defined fatal errors -- -- - exceptions are meant to be caught in order to recover the currently -- executed operation; they turn into fatal errors if they are not caught; -- execeptions are tagged, which allows to deal with multiple kinds of -- execeptions at the same time and to handle them differently -- - user-defined fatal errors abort the currently executed operation, but -- they may be caught at the top-level in order to terminate gracefully or -- to invoke another operation; there is no special support for different -- handling of different kinds of fatal-errors -- -- * the costs for fatal error handling are already incurred by the `IO' monad; -- the costs for exceptions mainly is the case distinction in the definition -- of `+>=' -- -- throw an exception with the given tag and message (EXPORTED) -- throwExc :: String -> String -> STB bs gs a throwExc tag msg = STB $ \bs gs -> return (bs, gs, Left (tag, msg)) -- raise a fatal user-defined error (EXPORTED) -- -- * such an error my be caught and handled using `fatalsHandeledBy' -- fatal :: String -> STB bs gs a fatal s = liftIO (ioError (userError s)) -- the given state transformer is executed and exceptions with the given tag -- are caught using the provided handler, which expects to get the exception -- message (EXPORTED) -- -- * the base and generic state observed by the exception handler is *modified* -- by the failed state transformer upto the point where the exception was -- thrown (this semantics is the only reasonable when it should be possible -- to use updating for maintaining the state) -- catchExc :: STB bs gs a -> (String, String -> STB bs gs a) -> STB bs gs a catchExc m (tag, handler) = STB $ \bs gs -> let STB m' = m in m' bs gs >>= \state@(bs', gs', res) -> case res of Left (tag', msg) -> if (tag == tag') -- exception with... then let STB handler' = handler msg in handler' bs' gs' -- correct tag, catch else return state -- wrong tag, rethrow Right _ -> return state -- no exception -- given a state transformer that may raise fatal errors and an error handler -- for fatal errors, execute the state transformer and apply the error handler -- when a fatal error occurs (EXPORTED) -- -- * fatal errors are IO monad errors and errors raised by `fatal' as well as -- uncaught exceptions -- -- * the base and generic state observed by the error handler is *in contrast -- to `catch'* the state *before* the state transformer is applied -- fatalsHandledBy :: STB bs gs a -> (IOError -> STB bs gs a) -> STB bs gs a fatalsHandledBy m handler = STB $ \bs gs -> (let STB m' = m in m' bs gs >>= \state@(gs', bs', res) -> case res of Left (tag, msg) -> let err = userError ("Exception `" ++ tag ++ "': " ++ msg) in ioError err Right a -> return state ) `catch` (\err -> let STB handler' = handler err in handler' bs gs) -- list mutable variables and arrays stuff into `STB'; all (EXPORTED) -- ------------------------------------------------------------------ type MVar a = IORef a newMV :: a -> STB bs gs (MVar a) newMV x = liftIO (newIORef x) readMV :: MVar a -> STB bs gs a readMV mv = liftIO (readIORef mv) assignMV :: MVar a -> a -> STB bs gs () assignMV mv x = liftIO (writeIORef mv x)