Ticket #2273: T2273.hs

File T2273.hs, 1.0 KB (added by morabbin, 15 months ago)
Line 
1module Q (tcExtendIdEnv2) where
2
3-- Interesting code:
4
5tcExtendIdEnv2 :: M a
6tcExtendIdEnv2 = do env <- getEnv
7                    let level :: Int
8                        level = thLevel (tcl_th_ctxt env)
9                    level `seq` tc_extend_local_id_env level
10
11{-# NOINLINE tc_extend_local_id_env #-}
12tc_extend_local_id_env :: Int -> M a
13tc_extend_local_id_env th_lvl = if read "foo"
14                                then th_lvl `seq` return undefined
15                                else return undefined
16
17thLevel :: ThStage -> Int
18thLevel Comp       = 0
19thLevel (Splice l) = l
20thLevel (Brack l)  = l
21
22-- Dull code:
23
24type M a = IOEnv TcLclEnv a
25
26data TcLclEnv = TcLclEnv { tcl_th_ctxt :: !ThStage }
27
28data ThStage = Comp | Splice Int | Brack  Int
29
30getEnv :: IOEnv env env
31getEnv = IOEnv (\ env -> return env)
32
33newtype IOEnv env a = IOEnv { unIOEnv :: env -> IO a }
34
35instance Monad (IOEnv m) where
36    IOEnv m >>= f = IOEnv (\ env -> do r <- m env
37                                       unIOEnv (f r) env )
38    return a = IOEnv (\ _ -> return a)
39    fail = error