%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[MainMonad]{I/O monad used in @Main@ module of the compiler}
module MainMonad (
MainIO(..),
-#ifndef __GLASGOW_HASKELL__
- mainIOtoDialogue,
- appendFileMn,
-#endif
returnMn,
thenMn,
thenMn_,
getArgsMn,
getSplitUniqSupplyMn,
exitMn,
-#if __GLASGOW_HASKELL__ >= 23
fopen, fclose, fwrite, _FILE(..),
-#endif
- SplitUniqSupply
+ UniqSupply
IF_ATTACK_PRAGMAS(COMMA getArgsPrimIO)
IF_ATTACK_PRAGMAS(COMMA appendFilePrimIO)
IF_ATTACK_PRAGMAS(COMMA appendChanPrimIO)
IF_ATTACK_PRAGMAS(COMMA mkSplitUniqSupply) -- profiling only, really
) where
-#ifdef __GLASGOW_HASKELL__
+#if __HASKELL1__ >= 3
+import LibSystem
+#endif
-# if __GLASGOW_HASKELL__ < 26
-import PreludePrimIO
-# endif
import PreludeGlaST
-#endif
+import Ubiq{-uitous-}
-import SplitUniq
-import Outputable
-import Util
+import UniqSupply ( mkSplitUniqSupply, UniqSupply )
infixr 9 `thenMn` -- right-associative, please
infixr 9 `thenMn_`
\end{code}
-For Glasgow Haskell, we'll eventually be able to use the underlying
-Glasgow I/O {\em directly}. However, for now we do the business
-through regular a @Dialogue@.
-
A value of type @MainIO a@ represents an I/O-performing computation
returning a value of type @a@. It is a function from the whole list
of responses-to-the-rest-of-the-program, to a triple consisting of:
returnMn :: a -> MainIO a
thenMn :: MainIO a -> (a -> MainIO b) -> MainIO b
thenMn_ :: MainIO a -> MainIO b -> MainIO b
---foldlMn :: (a -> b -> MainIO a) -> a -> [b] -> MainIO a
+#if __HASKELL1__ < 3
readMn :: String{-channel-} -> MainIO String
writeMn :: String{-channel-} -> String -> MainIO ()
-#ifndef __GLASGOW_HASKELL__
-appendFileMn:: String{-filename-} -> String -> MainIO ()
+#else
+readMn :: Handle -> MainIO String
+writeMn :: Handle -> String -> MainIO ()
#endif
+
getArgsMn :: MainIO [String]
-getSplitUniqSupplyMn :: Char -> MainIO SplitUniqSupply
+getSplitUniqSupplyMn
+ :: Char -> MainIO UniqSupply
exitMn :: Int -> MainIO ()
-#ifdef __GLASGOW_HASKELL__
{-# INLINE returnMn #-}
{-# INLINE thenMn #-}
{-# INLINE thenMn_ #-}
-#endif
-
-{- INLINEd at its uses
-foldlMn f z [] = returnMn z
-foldlMn f z (x:xs) = f z x `thenMn` \ zz ->
- foldlMn f zz xs
--}
exitMn val
- = -- trace ("exitMn:"++(show val)) (
- if val /= 0
+ = if val /= 0
then error "Compilation had errors\n"
else returnMn ()
- -- )
-#ifdef __GLASGOW_HASKELL__
+#if __HASKELL1__ < 3
type MainIO a = PrimIO a
getArgsMn = getArgsPrimIO
getSplitUniqSupplyMn char = mkSplitUniqSupply char
-\end{code}
-
-\begin{code}
-#else {- ! __GLASGOW_HASKELL -}
-
-type MainIO a = (a -> Dialogue) -> Dialogue
-
--- returnMn :: x -> MainIO x
-returnMn x cont = cont x
-
--- thenMn :: MainIO a -> (a -> MainIO b) -> MainIO b
-thenMn m k cont = m (\ a -> k a cont)
-
--- thenMn_ :: MainIO a -> MainIO b -> MainIO b
-thenMn_ m k cont = m (\ _ -> k cont)
-\end{code}
-
-\begin{code}
-mainIOtoDialogue :: MainIO () -> Dialogue
-
-mainIOtoDialogue io = io (\ _ _ -> [])
-
-readMn chan = readChanIO chan
-writeMn chan str = appendChanIO chan str
-appendFileMn fname str = appendFileIO fname str
-getArgsMn = getArgsIO
-
-getSplitUniqSupplyMn char = returnMn (mkSplitUniqSupply char)
-\end{code}
-
-\begin{code}
-processRequestIO :: Request -> MainIO Response
-processRequestIO req cont ~(resp:resps) = req : cont resp resps
-
-doneIO :: MainIO a
-doneIO cont = \ _ -> []
-
-data IoResult a = IoSucc a
- | IoFail IOError
-type IOE a = MainIO (IoResult a)
+#else {- 1.3 -}
-processRequestIOUnit :: Request -> IOE ()
-processRequestIOUnit req =
- processRequestIO req `thenMn` \ resp ->
- case resp of
- Success -> returnMn (IoSucc ())
- Str str -> error "funny Response, expected a Success"
- StrList strl -> error "funny Response, expected a Success"
- Failure ioerr -> returnMn (IoFail ioerr)
+type MainIO a = IO a
-processRequestIOString :: Request -> IOE String
-processRequestIOString req =
- processRequestIO req `thenMn` \ resp ->
- case resp of
- Success -> error "funny Response, expected a String"
- Str str -> returnMn (IoSucc str)
- StrList strl -> error "funny Response, expected a String"
- Failure ioerr -> returnMn (IoFail ioerr)
+returnMn = return
+thenMn = (>>=)
+thenMn_ = (>>)
-processRequestIOStringList :: Request -> IOE [String]
-processRequestIOStringList req =
- processRequestIO req `thenMn` \ resp ->
- case resp of
- Success -> error "funny Response, expected a [String]"
- Str str -> error "funny Response, expected a [String]"
- StrList strl -> returnMn (IoSucc strl)
- Failure ioerr -> returnMn (IoFail ioerr)
+readMn chan = hGetContents chan
+writeMn chan str = hPutStr chan str
+getArgsMn = getArgs
-readFileIOE :: String -> IOE String
-writeFileIOE :: String -> String -> IOE ()
-appendFileIOE :: String -> String -> IOE ()
-deleteFileIOE :: String -> IOE ()
-statusFileIOE :: String -> IOE String
-readChanIOE :: String -> IOE String
-appendChanIOE :: String -> String -> IOE ()
-statusChanIOE :: String -> IOE String
-echoIOE :: Bool -> IOE ()
-getArgsIOE :: IOE [String]
-getEnvIOE :: String -> IOE String
-setEnvIOE :: String -> String -> IOE ()
-sigActionIOE :: Int -> SigAct -> IOE ()
+getSplitUniqSupplyMn char
+ = mkSplitUniqSupply char `thenPrimIO` \ us ->
+ return us
-readFileIOE file = processRequestIOString ( ReadFile file )
-writeFileIOE file str = processRequestIOUnit ( WriteFile file str )
-appendFileIOE file str = processRequestIOUnit ( AppendFile file str )
-deleteFileIOE file = processRequestIOUnit ( DeleteFile file )
-statusFileIOE file = processRequestIOString ( StatusFile file )
-readChanIOE chan = processRequestIOString ( ReadChan chan )
-appendChanIOE chan str = processRequestIOUnit ( AppendChan chan str )
-statusChanIOE chan = processRequestIOString ( StatusChan chan )
-echoIOE bool = processRequestIOUnit ( Echo bool )
-getArgsIOE = processRequestIOStringList ( GetArgs )
-getEnvIOE var = processRequestIOString ( GetEnv var )
-setEnvIOE var obj = processRequestIOUnit ( SetEnv var obj )
-sigActionIOE sig act = processRequestIOUnit ( SigAction sig act )
-
-handleErrIO :: IoResult a -> MainIO a
-handleErrIO (IoSucc a) = returnMn a
-handleErrIO (IoFail ioerr) = exitIO ioerr
-
-readFileIO :: String -> MainIO String
-writeFileIO :: String -> String -> MainIO ()
-appendFileIO :: String -> String -> MainIO ()
-deleteFileIO :: String -> MainIO ()
-statusFileIO :: String -> MainIO String
-readChanIO :: String -> MainIO String
-appendChanIO :: String -> String -> MainIO ()
-statusChanIO :: String -> MainIO String
-echoIO :: Bool -> MainIO ()
-getArgsIO :: MainIO [String]
-getEnvIO :: String -> MainIO String
-setEnvIO :: String -> String -> MainIO ()
-sigActionIO :: Int -> SigAct -> MainIO ()
-
-readFileIO file = readFileIOE file `thenMn` handleErrIO
-writeFileIO file str = writeFileIOE file str `thenMn` handleErrIO
-appendFileIO file str = appendFileIOE file str `thenMn` handleErrIO
-deleteFileIO file = deleteFileIOE file `thenMn` handleErrIO
-statusFileIO file = statusFileIOE file `thenMn` handleErrIO
-readChanIO chan = readChanIOE chan `thenMn` handleErrIO
-appendChanIO chan str = appendChanIOE chan str `thenMn` handleErrIO
-statusChanIO chan = statusChanIOE chan `thenMn` handleErrIO
-echoIO bool = echoIOE bool `thenMn` handleErrIO
-getArgsIO = getArgsIOE `thenMn` handleErrIO
-getEnvIO var = getEnvIOE var `thenMn` handleErrIO
-setEnvIO var obj = setEnvIOE var obj `thenMn` handleErrIO
-sigActionIO sig act = sigActionIOE sig act `thenMn` handleErrIO
-
-exitIO :: IOError -> MainIO a
-
-exitIO (ReadError s) = error s
-exitIO (WriteError s) = error s
-exitIO (SearchError s) = error s
-exitIO (FormatError s) = error s
-exitIO (OtherError s) = error s
-\end{code}
-
-\begin{code}
-#endif {- ! __GLASGOW_HASKELL -}
+#endif {- 1.3 -}
\end{code}
projects / ghc-hetmet.git / blobdiff