22352ead05a5f22fc5ac65864eccf8d2f57736fa
[ghc.git] / testsuite / tests / cpranal / should_compile / Cpr001_imp.hs
1 -- $Id: Cpr001_imp.hs,v 1.1 2001/08/22 12:21:15 simonmar Exp $
2
3 module Cpr001_imp where
4
5 import Control.Applicative (Applicative(..))
6 import Control.Monad (liftM, ap)
7
8 data MS = MS { instr :: String
9 , pc :: Int
10 , mem :: String
11 , stack :: String
12 , frames :: [String]
13 , status :: Maybe String
14 }
15
16
17 newtype StateTrans s a = ST ( s -> (s, Maybe a))
18
19 -- state monad with error handling
20 -- in case of an error, the state remains
21 -- as it is and Nothing is returned as value
22 -- else execution continues
23
24 instance Functor (StateTrans s) where
25 fmap = liftM
26
27 instance Applicative (StateTrans s) where
28 pure = return
29 (<*>) = ap
30
31 instance Monad (StateTrans s) where
32 (ST p) >>= k
33 = ST (\s0 -> let
34 (s1, r0) = p s0
35 in
36 case r0 of
37 Just v -> let
38 (ST q) = k v
39 in
40 q s1
41 Nothing -> (s1, Nothing)
42 )
43 return v
44 = ST (\s -> (s, Just v))
45
46
47 -- machine state transitions
48
49 type MachineStateTrans = StateTrans MS
50
51 type MST = MachineStateTrans
52
53 {-# NOINLINE setMTerminated #-}
54 setMTerminated
55 = ST (\ms -> (ms { status = Just "Terminated" }, Just ()))
56
57 setMSvc call
58 = ST (\ms -> (ms { status = Just "Service" }, Just ()))
59
60 -- -------------------------------------------------------------------
61
62 data Instr
63 = LoadI Int -- load int const
64 | SysCall String -- system call (svc)
65