ghc/compiler/main/MainMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[MainMonad]{I/O monad used in @Main@ module of the compiler}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module MainMonad (
  10         MainIO(..),
  11 #ifndef __GLASGOW_HASKELL__
  12         mainIOtoDialogue,
  13         appendFileMn,
  14 #endif
  15         returnMn,
  16         thenMn,
  17         thenMn_,
  18 --      foldlMn, INLINEd at its two (important) uses...
  19         readMn,
  20         writeMn,
  21         getArgsMn,
  22         getSplitUniqSupplyMn,
  23         exitMn,
  24 #if __GLASGOW_HASKELL__ >= 23
  25         fopen, fclose, fwrite, _FILE(..),
  26 #endif
  27
  28         SplitUniqSupply
  29         IF_ATTACK_PRAGMAS(COMMA getArgsPrimIO)
  30         IF_ATTACK_PRAGMAS(COMMA appendFilePrimIO)
  31         IF_ATTACK_PRAGMAS(COMMA appendChanPrimIO)
  32         IF_ATTACK_PRAGMAS(COMMA readChanPrimIO)
  33         IF_ATTACK_PRAGMAS(COMMA mkSplitUniqSupply) -- profiling only, really
  34     ) where
  35
  36 #ifdef __GLASGOW_HASKELL__
  37
  38 # if __GLASGOW_HASKELL__ < 26
  39 import PreludePrimIO
  40 # endif
  41 import PreludeGlaST
  42
  43 #endif
  44
  45 import SplitUniq
  46 import Outputable
  47 import Util
  48
  49 infixr 9 `thenMn`       -- right-associative, please
  50 infixr 9 `thenMn_`
  51 \end{code}
  52
  53 For Glasgow Haskell, we'll eventually be able to use the underlying
  54 Glasgow I/O {\em directly}.  However, for now we do the business
  55 through regular a @Dialogue@.
  56
  57 A value of type @MainIO a@ represents an I/O-performing computation
  58 returning a value of type @a@.  It is a function from the whole list
  59 of responses-to-the-rest-of-the-program, to a triple consisting of:
  60 \begin{enumerate}
  61 \item
  62 the value of type @a@;
  63 \item
  64 a function which prefixes the requests for the computation to
  65 the front of a supplied list of requests; using a function here
  66 avoids an expensive append operation in @thenMn@;
  67 \item
  68 the depleted list of responses.
  69 \end{enumerate}
  70
  71 \begin{code}
  72 returnMn    :: a -> MainIO a
  73 thenMn      :: MainIO a -> (a -> MainIO b) -> MainIO b
  74 thenMn_     :: MainIO a -> MainIO b -> MainIO b
  75 --foldlMn           :: (a -> b -> MainIO a) -> a -> [b] -> MainIO a
  76
  77 readMn      :: String{-channel-} -> MainIO String
  78 writeMn     :: String{-channel-} -> String -> MainIO ()
  79 #ifndef __GLASGOW_HASKELL__
  80 appendFileMn:: String{-filename-} -> String -> MainIO ()
  81 #endif
  82 getArgsMn   :: MainIO [String]
  83 getSplitUniqSupplyMn :: Char -> MainIO SplitUniqSupply
  84 exitMn      :: Int -> MainIO ()
  85
  86 #ifdef __GLASGOW_HASKELL__
  87 {-# INLINE returnMn #-}
  88 {-# INLINE thenMn   #-}
  89 {-# INLINE thenMn_  #-}
  90 #endif
  91
  92 {- INLINEd at its uses
  93 foldlMn f z []     = returnMn z
  94 foldlMn f z (x:xs) = f z x      `thenMn` \ zz ->
  95                      foldlMn f zz xs
  96 -}
  97
  98 exitMn val
  99   = -- trace ("exitMn:"++(show val)) (
 100     if val /= 0
 101     then error "Compilation had errors\n"
 102     else returnMn ()
 103     -- )
 104
 105 #ifdef __GLASGOW_HASKELL__
 106
 107 type MainIO a = PrimIO a
 108
 109 returnMn    = returnPrimIO
 110 thenMn      = thenPrimIO
 111 thenMn_     = seqPrimIO
 112
 113 readMn chan                 = readChanPrimIO chan
 114 writeMn chan str            = appendChanPrimIO chan str
 115 getArgsMn                   = getArgsPrimIO
 116
 117 getSplitUniqSupplyMn char = mkSplitUniqSupply char
 118 \end{code}
 119
 120 \begin{code}
 121 #else {- ! __GLASGOW_HASKELL -}
 122
 123 type MainIO a = (a -> Dialogue) -> Dialogue
 124
 125 -- returnMn :: x -> MainIO x
 126 returnMn x cont = cont x
 127
 128 -- thenMn :: MainIO a -> (a -> MainIO b) -> MainIO b
 129 thenMn m k cont = m (\ a -> k a cont)
 130
 131 -- thenMn_ :: MainIO a -> MainIO b -> MainIO b
 132 thenMn_ m k cont = m (\ _ -> k cont)
 133 \end{code}
 134
 135 \begin{code}
 136 mainIOtoDialogue :: MainIO () -> Dialogue
 137
 138 mainIOtoDialogue io = io (\ _ _ -> [])
 139
 140 readMn chan             = readChanIO chan
 141 writeMn chan str        = appendChanIO chan str
 142 appendFileMn fname str  = appendFileIO fname str
 143 getArgsMn               = getArgsIO
 144
 145 getSplitUniqSupplyMn char = returnMn (mkSplitUniqSupply char)
 146 \end{code}
 147
 148 \begin{code}
 149 processRequestIO   :: Request -> MainIO Response
 150 processRequestIO req cont ~(resp:resps) = req : cont resp resps
 151
 152 doneIO :: MainIO a
 153 doneIO cont = \ _ -> []
 154
 155 data IoResult a = IoSucc a
 156                 | IoFail IOError
 157
 158 type IOE a = MainIO (IoResult a)
 159
 160 processRequestIOUnit :: Request -> IOE ()
 161 processRequestIOUnit req =
 162         processRequestIO req                           `thenMn` \ resp ->
 163         case resp of
 164           Success       -> returnMn (IoSucc ())
 165           Str str       -> error "funny Response, expected a Success"
 166           StrList strl  -> error "funny Response, expected a Success"
 167           Failure ioerr -> returnMn (IoFail ioerr)
 168
 169 processRequestIOString :: Request -> IOE String
 170 processRequestIOString req =
 171         processRequestIO req                           `thenMn` \ resp ->
 172         case resp of
 173           Success       -> error "funny Response, expected a String"
 174           Str str       -> returnMn (IoSucc str)
 175           StrList strl  -> error "funny Response, expected a String"
 176           Failure ioerr -> returnMn (IoFail ioerr)
 177
 178 processRequestIOStringList :: Request -> IOE [String]
 179 processRequestIOStringList req =
 180         processRequestIO req                           `thenMn` \ resp ->
 181         case resp of
 182           Success       -> error "funny Response, expected a [String]"
 183           Str str       -> error "funny Response, expected a [String]"
 184           StrList strl  -> returnMn (IoSucc strl)
 185           Failure ioerr -> returnMn (IoFail ioerr)
 186
 187 readFileIOE     :: String ->           IOE String
 188 writeFileIOE    :: String -> String -> IOE ()
 189 appendFileIOE   :: String -> String -> IOE ()
 190 deleteFileIOE   :: String ->           IOE ()
 191 statusFileIOE   :: String ->           IOE String
 192 readChanIOE     :: String ->           IOE String
 193 appendChanIOE   :: String -> String -> IOE ()
 194 statusChanIOE   :: String ->           IOE String
 195 echoIOE         :: Bool   ->           IOE ()
 196 getArgsIOE      ::                     IOE [String]
 197 getEnvIOE       :: String ->           IOE String
 198 setEnvIOE       :: String -> String -> IOE ()
 199 sigActionIOE    :: Int    -> SigAct -> IOE ()
 200
 201 readFileIOE    file     = processRequestIOString     ( ReadFile file )
 202 writeFileIOE   file str = processRequestIOUnit       ( WriteFile file str )
 203 appendFileIOE  file str = processRequestIOUnit       ( AppendFile file str )
 204 deleteFileIOE  file     = processRequestIOUnit       ( DeleteFile file )
 205 statusFileIOE  file     = processRequestIOString     ( StatusFile file )
 206 readChanIOE    chan     = processRequestIOString     ( ReadChan chan )
 207 appendChanIOE  chan str = processRequestIOUnit       ( AppendChan chan str )
 208 statusChanIOE  chan     = processRequestIOString     ( StatusChan chan )
 209 echoIOE        bool     = processRequestIOUnit       ( Echo bool )
 210 getArgsIOE              = processRequestIOStringList ( GetArgs )
 211 getEnvIOE      var      = processRequestIOString     ( GetEnv var )
 212 setEnvIOE      var obj  = processRequestIOUnit       ( SetEnv var obj )
 213 sigActionIOE   sig act  = processRequestIOUnit       ( SigAction sig act )
 214
 215 handleErrIO :: IoResult a -> MainIO a
 216 handleErrIO (IoSucc a)     = returnMn a
 217 handleErrIO (IoFail ioerr) = exitIO   ioerr
 218
 219 readFileIO      :: String ->           MainIO String
 220 writeFileIO     :: String -> String -> MainIO ()
 221 appendFileIO    :: String -> String -> MainIO ()
 222 deleteFileIO    :: String ->           MainIO ()
 223 statusFileIO    :: String ->           MainIO String
 224 readChanIO      :: String ->           MainIO String
 225 appendChanIO    :: String -> String -> MainIO ()
 226 statusChanIO    :: String ->           MainIO String
 227 echoIO          :: Bool   ->           MainIO ()
 228 getArgsIO       ::                     MainIO [String]
 229 getEnvIO        :: String ->           MainIO String
 230 setEnvIO        :: String -> String -> MainIO ()
 231 sigActionIO     :: Int    -> SigAct -> MainIO ()
 232
 233 readFileIO      file       = readFileIOE file           `thenMn` handleErrIO
 234 writeFileIO     file str   = writeFileIOE file str      `thenMn` handleErrIO
 235 appendFileIO    file str   = appendFileIOE file str     `thenMn` handleErrIO
 236 deleteFileIO    file       = deleteFileIOE file         `thenMn` handleErrIO
 237 statusFileIO    file       = statusFileIOE file         `thenMn` handleErrIO
 238 readChanIO      chan       = readChanIOE chan           `thenMn` handleErrIO
 239 appendChanIO    chan str   = appendChanIOE chan str     `thenMn` handleErrIO
 240 statusChanIO    chan       = statusChanIOE chan         `thenMn` handleErrIO
 241 echoIO          bool       = echoIOE bool               `thenMn` handleErrIO
 242 getArgsIO                  = getArgsIOE                 `thenMn` handleErrIO
 243 getEnvIO        var        = getEnvIOE var              `thenMn` handleErrIO
 244 setEnvIO        var obj    = setEnvIOE var obj          `thenMn` handleErrIO
 245 sigActionIO     sig act    = sigActionIOE sig act       `thenMn` handleErrIO
 246
 247 exitIO     :: IOError -> MainIO a
 248
 249 exitIO (ReadError s)   = error s
 250 exitIO (WriteError s)  = error s
 251 exitIO (SearchError s) = error s
 252 exitIO (FormatError s) = error s
 253 exitIO (OtherError s)  = error s
 254 \end{code}
 255
 256 \begin{code}
 257 #endif {- ! __GLASGOW_HASKELL -}
 258 \end{code}