blob: 2753071441d86931666b47c7d930605167f6e80e (
about) (
plain)
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
|
module PreludeLocalIO where
import PreludeIOPrims
import PreludeIOMonad
{-#Prelude#-} -- Indicates definitions of compiler prelude symbols
data IOResponse a = Succ a | Fail String deriving Text
exec :: ([Response] -> [Request]) -> IO ()
{-
-- Sunderesh's original definition
exec p = case (p bottom) of
[] -> unitIO ()
(q:qs) -> processRequest q `bindIO` \r ->
exec (\rs -> tail (p (r:rs)))
bottom :: a
bottom = error "Should never be evaluated"
-}
-- modified from the existing compiler. no quadratic behavior
-- needs
-- pure :: IO a -> a
-- other alternatives:
-- 1. use reference cells
-- 2. implement exec in Lisp
exec p = os requests `bindIO` \x -> unitIO () where
requests = p responses
responses = pureIO (os requests)
os :: [Request] -> IO [Response]
os [] = unitIO []
os (q:qs) = processRequest q `bindIO` \r ->
os qs `bindIO` \rs ->
unitIO (r:rs)
processRequest :: Request -> IO Response
-- This needs to be rewritten in terms of the continuation based defs
processRequest request =
case request of
-- File system requests
ReadFile name ->
primReadStringFile name `bindIO` \a ->
case a of
Succ s -> unitIO (Str s)
Fail e -> unitIO (Failure e)
WriteFile name contents ->
primWriteStringFile name contents `bindIO` \a ->
case a of
MaybeNot -> unitIO Success
Maybe e -> unitIO (Failure e)
AppendFile name contents ->
primAppendStringFile name contents `bindIO` \a ->
case a of
MaybeNot -> unitIO Success
Maybe e -> unitIO (Failure e)
ReadBinFile name ->
primReadBinFile name `bindIO` \a ->
case a of
Succ s -> unitIO (Bn s)
Fail e -> unitIO (Failure e)
WriteBinFile name bin ->
primWriteBinFile name bin `bindIO` \a ->
case a of
MaybeNot -> unitIO Success
Maybe e -> unitIO (Failure e)
AppendBinFile name bin ->
primAppendBinFile name bin `bindIO` \a ->
case a of
MaybeNot -> unitIO Success
Maybe e -> unitIO (Failure e)
DeleteFile name ->
primDeleteFile name `bindIO` \a ->
case a of
MaybeNot -> Success
Maybe e -> unitIO (Failure e)
StatusFile name ->
primStatusFile name `bindIO` \a ->
case a of
Succ s -> unitIO (Str s)
Fail e -> unitIO (Failure e)
-- Channel system requests
ReadChan name ->
primReadChan name `bindIO` \a ->
case a of
Succ s -> unitIO (Str s)
Fail e -> unitIO (Failure e)
AppendChan name string ->
primAppendChan name string `bindIO` \a ->
case a of
MaybeNot -> unitIO Success
Maybe e -> unitIO (Failure e)
ReadBinChan name ->
primReadBinChan name `bindIO` \a ->
case a of
Succ s -> unitIO (Bn s)
Fail e -> unitIO (Failure e)
AppendBinChan name bin ->
primAppendBinChan name bin `bindIO` \a ->
case a of
MaybeNot -> unitIO Success
Maybe e -> unitIO (Failure e)
StatusChan name ->
primStatusChan name `bindIO` \a ->
case a of
Succ s -> unitIO (Str s)
Fail e -> unitIO (Failure e)
-- Environment requests
Echo status ->
primEcho status `bindIO` \a ->
case a of
Succ s -> unitIO (Str s)
Fail e -> unitIO (Failure e)
GetArgs ->
primGetArgs `bindIO` \a ->
case a of
Succ s -> unitIO (Str s)
Fail e -> unitIO (Failure e)
GetProgName ->
primProgArgs `bindIO` \a ->
case a of
Succ s -> unitIO (Str s)
Fail e -> unitIO (Failure e)
GetEnv name ->
primGetEnv name `bindIO` \a ->
case a of
Succ s -> unitIO (Str s)
Fail e -> unitIO (Failure e)
SetEnv name string ->
primGetEnv name string `bindIO` \a ->
case a of
Succ s -> unitIO (Str s)
Fail e -> unitIO (Failure e)
_ -> unitIO (Failure (OtherError "Unrecognized IO Feature"))
-- Monadic Style IO
-- Channel system requests
|
