ghc/lib/prelude/IO.hs

   1 -- *** what's left after removing data/type decls
   2
   3 -- I/O functions and definitions
   4
   5 module PreludeIO  where
   6
   7 import Cls
   8 import Core
   9 import List             ( (++), foldr )
  10 import PS               ( _PackedString, _unpackPS )
  11 import Text
  12 import TyIO
  13
  14 -- File and channel names:
  15
  16 stdin       =  "stdin"
  17 stdout      =  "stdout"
  18 stderr      =  "stderr"
  19 stdecho     =  "stdecho"
  20
  21 done          ::                                                Dialogue
  22 readFile      :: String ->           FailCont -> StrCont     -> Dialogue
  23 writeFile     :: String -> String -> FailCont -> SuccCont    -> Dialogue
  24 appendFile    :: String -> String -> FailCont -> SuccCont    -> Dialogue
  25 readBinFile   :: String ->           FailCont -> BinCont     -> Dialogue
  26 writeBinFile  :: String -> Bin    -> FailCont -> SuccCont    -> Dialogue
  27 appendBinFile :: String -> Bin    -> FailCont -> SuccCont    -> Dialogue
  28 deleteFile    :: String ->           FailCont -> SuccCont    -> Dialogue
  29 statusFile    :: String ->           FailCont -> StrCont     -> Dialogue
  30 readChan      :: String ->           FailCont -> StrCont     -> Dialogue
  31 appendChan    :: String -> String -> FailCont -> SuccCont    -> Dialogue
  32 readBinChan   :: String ->           FailCont -> BinCont     -> Dialogue
  33 appendBinChan :: String -> Bin    -> FailCont -> SuccCont    -> Dialogue
  34 statusChan    :: String ->           FailCont -> StrCont     -> Dialogue
  35 echo          :: Bool   ->           FailCont -> SuccCont    -> Dialogue
  36 getArgs       ::                     FailCont -> StrListCont -> Dialogue
  37 getProgName   ::                     FailCont -> StrCont     -> Dialogue
  38 getEnv        :: String ->           FailCont -> StrCont     -> Dialogue
  39 setEnv        :: String -> String -> FailCont -> SuccCont    -> Dialogue
  40 sigAction     :: Int    -> SigAct -> FailCont -> SuccCont    -> Dialogue
  41
  42 done resps    =  []
  43
  44 readFile name fail succ resps =
  45      (ReadFile name) : strDispatch fail succ resps
  46
  47 writeFile name contents fail succ resps =
  48     (WriteFile name contents) : succDispatch fail succ resps
  49
  50 appendFile name contents fail succ resps =
  51     (AppendFile name contents) : succDispatch fail succ resps
  52
  53 readBinFile name fail succ resps =
  54     (ReadBinFile name) : binDispatch fail succ resps
  55
  56 writeBinFile name contents fail succ resps =
  57     (WriteBinFile name contents) : succDispatch fail succ resps
  58
  59 appendBinFile name contents fail succ resps =
  60     (AppendBinFile name contents) : succDispatch fail succ resps
  61
  62 deleteFile name fail succ resps =
  63     (DeleteFile name) : succDispatch fail succ resps
  64
  65 statusFile name fail succ resps =
  66     (StatusFile name) : strDispatch fail succ resps
  67
  68 readChan name fail succ resps =
  69     (ReadChan name) : strDispatch fail succ resps
  70
  71 appendChan name contents fail succ resps =
  72     (AppendChan name contents) : succDispatch fail succ resps
  73
  74 readBinChan name fail succ resps =
  75     (ReadBinChan name) : binDispatch fail succ resps
  76
  77 appendBinChan name contents fail succ resps =
  78     (AppendBinChan name contents) : succDispatch fail succ resps
  79
  80 statusChan name fail succ resps =
  81     (StatusChan name) : strDispatch fail succ resps
  82
  83 echo bool fail succ resps =
  84     (Echo bool) : succDispatch fail succ resps
  85
  86 getArgs fail succ resps =
  87         GetArgs : strListDispatch fail succ resps
  88
  89 getProgName fail succ resps =
  90         GetProgName : strDispatch fail succ resps
  91
  92 getEnv name fail succ resps =
  93         (GetEnv name) : strDispatch fail succ resps
  94
  95 setEnv name val fail succ resps =
  96         (SetEnv name val) : succDispatch fail succ resps
  97
  98 sigAction signal action fail succ resps =
  99         (SigAction signal action) : succDispatch fail succ resps
 100
 101 strDispatch fail succ (resp:resps) =
 102             case resp of Str val     -> succ val resps
 103                          Failure msg -> fail msg resps
 104
 105 strListDispatch fail succ (resp:resps) =
 106             case resp of StrList val -> succ val resps
 107                          Failure msg -> fail msg resps
 108
 109 binDispatch fail succ (resp:resps) =
 110             case resp of Bn val      -> succ val resps
 111                          Failure msg -> fail msg resps
 112
 113 succDispatch fail succ (resp:resps) =
 114             case resp of Success     -> succ resps
 115                          Failure msg -> fail msg resps
 116
 117
 118 abort           :: FailCont
 119 abort err       =  done
 120
 121 exit            :: FailCont
 122 exit err        = appendChan stderr (msg ++ "\n") abort done
 123                   where msg = case err of ReadError s   -> s
 124                                           WriteError s  -> s
 125                                           SearchError s -> s
 126                                           FormatError s -> s
 127                                           OtherError s  -> s
 128                                           EOD           -> "EOD"
 129
 130 print           :: (Text a) => a -> Dialogue
 131 print x         =  appendChan stdout (show x) exit done
 132 prints          :: (Text a) => a -> String -> Dialogue
 133 prints x s      =  appendChan stdout (shows x s) exit done
 134
 135 interact        :: (String -> String) -> Dialogue
 136 interact f      =  readChan stdin exit
 137                             (\x -> appendChan stdout (f x) exit done)