Ticket #2273: T2273.hs

module Q (tcExtendIdEnv2) where

-- Interesting code:

tcExtendIdEnv2 :: M a
tcExtendIdEnv2 = do env <- getEnv
                    let level :: Int
                        level = thLevel (tcl_th_ctxt env)
                    level `seq` tc_extend_local_id_env level

{-# NOINLINE tc_extend_local_id_env #-}
tc_extend_local_id_env :: Int -> M a
tc_extend_local_id_env th_lvl = if read "foo"
                                then th_lvl `seq` return undefined
                                else return undefined

thLevel :: ThStage -> Int
thLevel Comp       = 0
thLevel (Splice l) = l
thLevel (Brack l)  = l

-- Dull code:

type M a = IOEnv TcLclEnv a

data TcLclEnv = TcLclEnv { tcl_th_ctxt :: !ThStage }

data ThStage = Comp | Splice Int | Brack  Int

getEnv :: IOEnv env env
getEnv = IOEnv (\ env -> return env)

newtype IOEnv env a = IOEnv { unIOEnv :: env -> IO a }

instance Monad (IOEnv m) where
    IOEnv m >>= f = IOEnv (\ env -> do r <- m env
                                       unIOEnv (f r) env )
    return a = IOEnv (\ _ -> return a)
    fail = error