1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
|
-- I/O functions and definitions
module PreludeIO(stdin,stdout,stderr,stdecho,{-Request(..),Response(..),-}
IOError(..),Dialogue(..),IO(..),SystemState,IOResult,
SuccCont(..),StrCont(..),
StrListCont(..),BinCont(..),FailCont(..),
readFile, writeFile, appendFile, readBinFile,
writeBinFile, appendBinFile, deleteFile, statusFile,
readChan, appendChan, readBinChan, appendBinChan,
statusChan, echo, getArgs, getProgName, getEnv, setEnv,
done, exit, abort, print, prints, interact,
thenIO,thenIO_,seqIO,returnIO, doneIO)
where
import PreludeBltinIO
import PreludeBltinArray(strict1)
{-#Prelude#-} -- Indicates definitions of compiler prelude symbols
-- These datatypes are used by the monad.
type IO a = SystemState -> IOResult a
data SystemState = SystemState
data IOResult a = IOResult a
-- Operations in the monad
-- This definition is needed to allow proper tail recursion of the Lisp
-- code. The use of strict1 forces f1 s (since getState is strict) before
-- the call to f2. The optimizer removed getState and getRes from the
-- generated code.
{-# thenIO :: Inline #-}
thenIO f1 f2 s =
let g = f1 s
s' = getState g in
strict1 s' (f2 (getRes g) s')
{-# thenIO_ :: Inline #-}
x `thenIO_` y = x `thenIO` \_ -> y
x `seqIO` y = x `thenIO` \_ -> y
-- The returnIO function is implemented directly as a primitive.
doneIO = returnIO ()
-- File and channel names:
stdin = "stdin"
stdout = "stdout"
stderr = "stderr"
stdecho = "stdecho"
-- Requests and responses:
{- Not used since streams are no longer supported:
data Request = -- file system requests:
ReadFile String
| WriteFile String String
| AppendFile String String
| ReadBinFile String
| WriteBinFile String Bin
| AppendBinFile String Bin
| DeleteFile String
| StatusFile String
-- channel system requests:
| ReadChan String
| AppendChan String String
| ReadBinChan String
| AppendBinChan String Bin
| StatusChan String
-- environment requests:
| Echo Bool
| GetArgs
| GetProgName
| GetEnv String
| SetEnv String String
deriving Text
data Response = Success
| Str String
| StrList [String]
| Bn Bin
| Failure IOError
deriving Text
-}
data IOError = WriteError String
| ReadError String
| SearchError String
| FormatError String
| OtherError String
deriving Text
-- Continuation-based I/O:
type Dialogue = IO ()
type SuccCont = Dialogue
type StrCont = String -> Dialogue
type StrListCont = [String] -> Dialogue
type BinCont = Bin -> Dialogue
type FailCont = IOError -> Dialogue
done :: Dialogue
readFile :: String -> FailCont -> StrCont -> Dialogue
writeFile :: String -> String -> FailCont -> SuccCont -> Dialogue
appendFile :: String -> String -> FailCont -> SuccCont -> Dialogue
readBinFile :: String -> FailCont -> BinCont -> Dialogue
writeBinFile :: String -> Bin -> FailCont -> SuccCont -> Dialogue
appendBinFile :: String -> Bin -> FailCont -> SuccCont -> Dialogue
deleteFile :: String -> FailCont -> SuccCont -> Dialogue
statusFile :: String -> FailCont -> StrCont -> Dialogue
readChan :: String -> FailCont -> StrCont -> Dialogue
appendChan :: String -> String -> FailCont -> SuccCont -> Dialogue
readBinChan :: String -> FailCont -> BinCont -> Dialogue
appendBinChan :: String -> Bin -> FailCont -> SuccCont -> Dialogue
statusChan :: String -> FailCont -> StrCont -> Dialogue
echo :: Bool -> FailCont -> SuccCont -> Dialogue
getArgs :: FailCont -> StrListCont -> Dialogue
getProgName :: FailCont -> StrCont -> Dialogue
getEnv :: String -> FailCont -> StrCont -> Dialogue
setEnv :: String -> String -> FailCont -> SuccCont -> Dialogue
done = returnIO ()
readFile name fail succ =
primReadStringFile name `thenIO` objDispatch fail succ
writeFile name contents fail succ =
primWriteStringFile name contents `thenIO` succDispatch fail succ
appendFile name contents fail succ =
primAppendStringFile name contents `thenIO` succDispatch fail succ
readBinFile name fail succ =
primReadBinFile name `thenIO` objDispatch fail succ
writeBinFile name contents fail succ =
primWriteBinFile name contents `thenIO` succDispatch fail succ
appendBinFile name contents fail succ =
primAppendBinFile name contents `thenIO` succDispatch fail succ
deleteFile name fail succ =
primDeleteFile name `thenIO` succDispatch fail succ
statusFile name fail succ =
primStatusFile name `thenIO`
(\status -> case status of Succ s -> succ s
Fail msg -> fail (SearchError msg))
readChan name fail succ =
if name == stdin then
primReadStdin `thenIO` succ
else
badChan fail name
appendChan name contents fail succ =
if name == stdout then
primWriteStdout contents `thenIO` succDispatch fail succ
else
badChan fail name
readBinChan name fail succ =
if name == stdin then
primReadBinStdin `thenIO` objDispatch fail succ
else
badChan fail name
appendBinChan name contents fail succ =
if name == stdout then
primWriteBinStdout contents `thenIO` succDispatch fail succ
else
badChan fail name
statusChan name fail succ =
if name == stdin || name == stdout then
succ "0 0"
else
fail (SearchError "Channel not defined")
echo bool fail succ =
if bool then
succ
else
fail (OtherError "Echo cannot be turned off")
getArgs fail succ =
succ [""]
getProgName fail succ =
succ "haskell"
getEnv name fail succ =
primGetEnv name `thenIO` objDispatch fail succ
setEnv name val fail succ =
fail (OtherError "setEnv not implemented")
objDispatch fail succ r =
case r of Succ s -> succ s
Fail msg -> fail (OtherError msg)
succDispatch fail succ r =
case r of Succ _ -> succ
Fail msg -> fail (OtherError msg)
badChan f name = f (OtherError ("Improper IO Channel: " ++ name))
abort :: FailCont
abort err = done
exit :: FailCont
exit err = appendChan stderr (msg ++ "\n") abort done
where msg = case err of ReadError s -> s
WriteError s -> s
SearchError s -> s
FormatError s -> s
OtherError s -> s
print :: (Text a) => a -> Dialogue
print x = appendChan stdout (show x) exit done
prints :: (Text a) => a -> String -> Dialogue
prints x s = appendChan stdout (shows x s) exit done
interact :: (String -> String) -> Dialogue
interact f = readChan stdin exit
(\x -> appendChan stdout (f x) exit done)
|
