base: Remove `Monad(fail)` method and reexport `MonadFail(fail)` instead
[ghc.git] / testsuite / tests / programs / galois_raytrace / Eval.hs
1 -- Copyright (c) 2000 Galois Connections, Inc.
2 -- All rights reserved. This software is distributed as
3 -- free software under the license in the file "LICENSE",
4 -- which is included in the distribution.
5
6 module Eval where
7
8 import Control.Monad
9 import Data.Array
10
11 import Geometry
12 import CSG
13 import Surface
14 import Data
15 import Parse (rayParse, rayParseF)
16
17 class Monad m => MonadEval m where
18 doOp :: PrimOp -> GMLOp -> Stack -> m Stack
19 tick :: m ()
20 err :: String -> m a
21
22 tick = return ()
23
24 newtype Pure a = Pure a deriving Show
25
26 instance Functor Pure where
27 fmap = liftM
28
29 instance Applicative Pure where
30 pure = Pure
31 (<*>) = ap
32
33 instance Monad Pure where
34 Pure x >>= k = k x
35 return = pure
36
37 instance MonadEval Pure where
38 doOp = doPureOp
39 err s = error s
40
41 instance MonadEval IO where
42 doOp prim op stk = do { -- putStrLn ("Calling " ++ show op
43 -- ++ " << " ++ show stk ++ " >>")
44 doAllOp prim op stk
45 }
46 err s = error s
47
48 data State
49 = State { env :: Env
50 , stack :: Stack
51 , code :: Code
52 } deriving Show
53
54 callback :: Env -> Code -> Stack -> Stack
55 callback env code stk
56 = case eval (State { env = env, stack = stk, code = code}) of
57 Pure stk -> stk
58
59 {-# SPECIALIZE eval :: State -> Pure Stack #-}
60 {-# SPECIALIZE eval :: State -> IO Stack #-}
61
62 eval :: MonadEval m => State -> m Stack
63 eval st =
64 do { () <- return () -- $ unsafePerformIO (print st) -- Functional debugger
65 ; if moreCode st then
66 do { tick -- tick first, so as to catch loops on new eval.
67 ; st' <- step st
68 ; eval st'
69 }
70 else return (stack st)
71 }
72
73 moreCode :: State -> Bool
74 moreCode (State {code = []}) = False
75 moreCode _ = True
76
77 -- Step has a precondition that there *is* code to run
78 {-# SPECIALIZE step :: State -> Pure State #-}
79 {-# SPECIALIZE step :: State -> IO State #-}
80 step :: MonadEval m => State -> m State
81
82 -- Rule 1: Pushing BaseValues
83 step st@(State{ stack = stack, code = (TBool b):cs })
84 = return (st { stack = (VBool b):stack, code = cs })
85 step st@(State{ stack = stack, code = (TInt i):cs })
86 = return (st { stack = (VInt i):stack, code = cs })
87 step st@(State{ stack = stack, code = (TReal r):cs })
88 = return (st { stack = (VReal r):stack, code = cs })
89 step st@(State{ stack = stack, code = (TString s):cs })
90 = return (st { stack = (VString s):stack, code = cs })
91
92 -- Rule 2: Name binding
93 step st@(State{ env = env, stack = (v:stack), code = (TBind id):cs }) =
94 return (State { env = extendEnv env id v, stack = stack, code = cs })
95 step st@(State{ env = env, stack = [], code = (TBind id):cs }) =
96 err "Attempt to bind the top of an empty stack"
97
98 -- Rule 3: Name lookup
99 step st@(State{ env = env, stack = stack, code = (TId id):cs }) =
100 case (lookupEnv env id) of
101 Just v -> return (st { stack = v:stack, code = cs })
102 Nothing -> err ("Cannot find value for identifier: " ++ id)
103
104 -- Rule 4: Closure creation
105 step st@(State{ env = env, stack = stack, code = (TBody body):cs }) =
106 return (st { stack = (VClosure env body):stack, code = cs })
107
108 -- Rule 5: Application
109 step st@(State{ env = env, stack = (VClosure env' code'):stack, code = TApply:cs }) =
110 do { stk <- eval (State {env = env', stack = stack, code = code'})
111 ; return (st { stack = stk, code = cs })
112 }
113 step st@(State{ env = env, stack = [], code = TApply:cs }) =
114 err "Application with an empty stack"
115 step st@(State{ env = env, stack = _:_, code = TApply:cs }) =
116 err "Application of a non-closure"
117
118 -- Rule 6: Arrays
119 step st@(State{ env = env, stack = stack, code = TArray code':cs }) =
120 do { stk <- eval (State {env = env, stack = [], code = code'})
121 ; let last = length stk-1
122 ; let arr = array (0,last) (zip [last,last-1..] stk)
123 ; return (st { stack = (VArray arr):stack, code = cs })
124 }
125
126 -- Rule 7 & 8: If statement
127 step st@(State{ env = env, stack = (VClosure e2 c2):(VClosure e1 c1):(VBool True):stack, code = TIf:cs }) =
128 do { stk <- eval (State {env = e1, stack = stack, code = c1})
129 ; return (st { stack = stk, code = cs })
130 }
131 step st@(State{ env = env, stack = (VClosure e2 c2):(VClosure e1 c1):(VBool False):stack, code = TIf:cs }) =
132 do { stk <- eval (State {env = e2, stack = stack, code = c2})
133 ; return (st { stack = stk, code = cs })
134 }
135 step st@(State{ env = env, stack = _, code = TIf:cs }) =
136 err "Incorrect use of if (bad and/or inappropriate values on the stack)"
137
138 -- Rule 9: Operators
139 step st@(State{ env = env, stack = stack, code = (TOp op):cs }) =
140 do { stk <- doOp (opFnTable ! op) op stack
141 ; return (st { stack = stk, code = cs })
142 }
143
144 -- Rule Opps
145 step _ = err "Tripped on sidewalk while stepping."
146
147
148 --------------------------------------------------------------------------
149 -- Operator code
150
151 opFnTable :: Array GMLOp PrimOp
152 opFnTable = array (minBound,maxBound)
153 [ (op,prim) | (_,TOp op,prim) <- opcodes ]
154
155
156
157
158 doPureOp :: (MonadEval m) => PrimOp -> GMLOp -> Stack -> m Stack
159 doPureOp _ Op_render _ =
160 err ("\nAttempting to call render from inside a purely functional callback.")
161 doPureOp primOp op stk = doPrimOp primOp op stk -- call the purely functional operators
162
163 {-# SPECIALIZE doPrimOp :: PrimOp -> GMLOp -> Stack -> Pure Stack #-}
164 {-# SPECIALIZE doPrimOp :: PrimOp -> GMLOp -> Stack -> IO Stack #-}
165 {-# SPECIALIZE doPrimOp :: PrimOp -> GMLOp -> Stack -> Abs Stack #-}
166
167 doPrimOp :: (MonadEval m) => PrimOp -> GMLOp -> Stack -> m Stack
168
169 -- 1 argument.
170
171 doPrimOp (Int_Int fn) _ (VInt i1:stk)
172 = return ((VInt (fn i1)) : stk)
173 doPrimOp (Real_Real fn) _ (VReal r1:stk)
174 = return ((VReal (fn r1)) : stk)
175 doPrimOp (Point_Real fn) _ (VPoint x y z:stk)
176 = return ((VReal (fn x y z)) : stk)
177
178 -- This is where the callbacks happen from...
179 doPrimOp (Surface_Obj fn) _ (VClosure env code:stk)
180 = case absapply env code [VAbsObj AbsFACE,VAbsObj AbsU,VAbsObj AbsV] of
181 Just [VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3] ->
182 let
183 res = prop (color c1 c2 c3) r1 r2 r3
184 in
185 return ((VObject (fn (SConst res))) : stk)
186 _ -> return ((VObject (fn (SFun call))) : stk)
187 where
188 -- The most general case
189 call i r1 r2 =
190 case callback env code [VReal r2,VReal r1,VInt i] of
191 [VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3]
192 -> prop (color c1 c2 c3) r1 r2 r3
193 stk -> error ("callback failed: incorrectly typed return arguments"
194 ++ show stk)
195
196 doPrimOp (Real_Int fn) _ (VReal r1:stk)
197 = return ((VInt (fn r1)) : stk)
198 doPrimOp (Int_Real fn) _ (VInt r1:stk)
199 = return ((VReal (fn r1)) : stk)
200 doPrimOp (Arr_Int fn) _ (VArray arr:stk)
201 = return ((VInt (fn arr)) : stk)
202
203 -- 2 arguments.
204
205 doPrimOp (Int_Int_Int fn) _ (VInt i2:VInt i1:stk)
206 = return ((VInt (fn i1 i2)) : stk)
207 doPrimOp (Int_Int_Bool fn) _ (VInt i2:VInt i1:stk)
208 = return ((VBool (fn i1 i2)) : stk)
209 doPrimOp (Real_Real_Real fn) _ (VReal r2:VReal r1:stk)
210 = return ((VReal (fn r1 r2)) : stk)
211 doPrimOp (Real_Real_Bool fn) _ (VReal r2:VReal r1:stk)
212 = return ((VBool (fn r1 r2)) : stk)
213 doPrimOp (Arr_Int_Value fn) _ (VInt i:VArray arr:stk)
214 = return ((fn arr i) : stk)
215
216
217 -- Many arguments, typically image mangling
218
219 doPrimOp (Obj_Obj_Obj fn) _ (VObject o2:VObject o1:stk)
220 = return ((VObject (fn o1 o2)) : stk)
221 doPrimOp (Point_Color_Light fn) _ (VPoint r g b:VPoint x y z : stk)
222 = return (VLight (fn (x,y,z) (color r g b)) : stk)
223 doPrimOp (Point_Point_Color_Real_Real_Light fn) _
224 (VReal r2:VReal r1:VPoint r g b:VPoint x2 y2 z2:VPoint x1 y1 z1 : stk)
225 = return (VLight (fn (x1,y1,z1) (x2,y2,z2) (color r g b) r1 r2) : stk)
226 doPrimOp (Real_Real_Real_Point fn) _ (VReal r3:VReal r2:VReal r1:stk)
227 = return ((fn r1 r2 r3) : stk)
228 doPrimOp (Obj_Real_Obj fn) _ (VReal r:VObject o:stk)
229 = return (VObject (fn o r) : stk)
230 doPrimOp (Obj_Real_Real_Real_Obj fn) _ (VReal r3:VReal r2:VReal r1:VObject o:stk)
231 = return (VObject (fn o r1 r2 r3) : stk)
232
233 -- This one is our testing harness
234 doPrimOp (Value_String_Value fn) _ (VString s:o:stk)
235 = res `seq` return (res : stk)
236 where
237 res = fn o s
238
239 doPrimOp primOp op args
240 = err ("\n\ntype error when attempting to execute builtin primitive \"" ++
241 show op ++ "\"\n\n| " ++
242 show op ++ " takes " ++ show (length types) ++ " argument" ++ s
243 ++ " with" ++ the ++ " type" ++ s ++ "\n|\n|" ++
244 " " ++ unwords [ show ty | ty <- types ] ++ "\n|\n|" ++
245 " currently, the relevant argument" ++ s ++ " on the stack " ++
246 are ++ "\n|\n| " ++
247 unwords [ "(" ++ show arg ++ ")"
248 | arg <- reverse (take (length types) args) ] ++ "\n|\n| "
249 ++ " (top of stack is on the right hand side)\n\n")
250 where
251 len = length types
252 s = (if len /= 1 then "s" else "")
253 are = (if len /= 1 then "are" else "is")
254 the = (if len /= 1 then "" else " the")
255 types = getPrimOpType primOp
256
257
258 -- Render is somewhat funny, because it can only get called at top level.
259 -- All other operations are purely functional.
260
261 doAllOp :: PrimOp -> GMLOp -> Stack -> IO Stack
262 doAllOp (Render render) Op_render
263 (VString str:VInt ht:VInt wid:VReal fov
264 :VInt dep:VObject obj:VArray arr
265 :VPoint r g b : stk)
266 = do { render (color r g b) lights obj dep (fov * (pi / 180.0)) wid ht str
267 ; return stk
268 }
269 where
270 lights = [ light | (VLight light) <- elems arr ]
271
272 doAllOp primOp op stk = doPrimOp primOp op stk -- call the purely functional operators
273
274 ------------------------------------------------------------------------------
275 {-
276 - Abstract evaluation.
277 -
278 - The idea is you check for constant code that
279 - (1) does not look at its arguments
280 - (2) gives a fixed result
281 -
282 - We run for 100 steps.
283 -
284 -}
285
286 absapply :: Env -> Code -> Stack -> Maybe Stack
287 absapply env code stk =
288 case runAbs (eval (State env stk code)) 100 of
289 AbsState stk _ -> Just stk
290 AbsFail m -> Nothing
291
292 newtype Abs a = Abs { runAbs :: Int -> AbsState a }
293 data AbsState a = AbsState a !Int
294 | AbsFail String
295
296 instance Functor Abs where
297 fmap = liftM
298
299 instance Applicative Abs where
300 pure x = Abs (\ n -> AbsState x n)
301 (<*>) = ap
302
303 instance Monad Abs where
304 (Abs fn) >>= k = Abs (\ s -> case fn s of
305 AbsState r s' -> runAbs (k r) s'
306 AbsFail m -> AbsFail m)
307 return = pure
308
309 instance MonadFail Abs where
310 fail s = Abs (\ n -> AbsFail s)
311
312 instance MonadEval Abs where
313 doOp = doAbsOp
314 err = fail
315 tick = Abs (\ n -> if n <= 0
316 then AbsFail "run out of time"
317 else AbsState () (n-1))
318
319 doAbsOp :: PrimOp -> GMLOp -> Stack -> Abs Stack
320 doAbsOp _ Op_point (VReal r3:VReal r2:VReal r1:stk)
321 = return ((VPoint r1 r2 r3) : stk)
322 -- here, you could have an (AbsPoint :: AbsObj) which you put on the
323 -- stack, with any object in the three fields.
324 doAbsOp _ op _ = err ("operator not understood (" ++ show op ++ ")")
325
326 ------------------------------------------------------------------------------
327 -- Driver
328
329 mainEval :: Code -> IO ()
330 mainEval prog = do { stk <- eval (State emptyEnv [] prog)
331 ; return ()
332 }
333 {-
334 * Oops, one of the example actually has something
335 * on the stack at the end.
336 * Oh well...
337 ; if null stk
338 then return ()
339 else do { putStrLn done
340 ; print stk
341 }
342 -}
343
344 done = "Items still on stack at (successful) termination of program"
345
346 ------------------------------------------------------------------------------
347 -- testing
348
349 test :: String -> Pure Stack
350 test is = eval (State emptyEnv [] (rayParse is))
351
352 testF :: String -> IO Stack
353 testF is = do prog <- rayParseF is
354 eval (State emptyEnv [] prog)
355
356 testA :: String -> Either String (Stack,Int)
357 testA is = case runAbs (eval (State emptyEnv
358 [VAbsObj AbsFACE,VAbsObj AbsU,VAbsObj AbsV]
359 (rayParse is))) 100 of
360 AbsState a n -> Right (a,n)
361 AbsFail m -> Left m
362
363 abstest1 = "1.0 0.0 0.0 point /red { /v /u /face red 1.0 0.0 1.0 } apply"
364
365 -- should be [3:: Int]
366 et1 = test "1 /x { x } /f 2 /x f apply x addi"
367
368
369
370
371