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