- Fundmantal combinators specific to the monad
-%* *
-%************************************************************************
-
-Running it
-
-\begin{code}
-runTcRn :: Env m -> TcRn m a -> IO a
-runTcRn env (TcRn m) = m env
-\end{code}
-
-The fixpoint combinator
-
-\begin{code}
-{-# NOINLINE fixM #-}
- -- Aargh! Not inlining fixTc alleviates a space leak problem.
- -- Normally fixTc is used with a lazy tuple match: if the optimiser is
- -- shown the definition of fixTc, it occasionally transforms the code
- -- in such a way that the code generator doesn't spot the selector
- -- thunks. Sigh.
-
-fixM :: (a -> TcRn m a) -> TcRn m a
-fixM f = TcRn (\ env -> fixIO (\ r -> unTcRn (f r) env))
-\end{code}
-
-Error recovery
-
-\begin{code}
-tryM :: TcRn m r -> TcRn m (Either Exception r)
--- Reflect exception into TcRn monad
-tryM (TcRn thing) = TcRn (\ env -> tryJust tc_errors (thing env))
- where
-#if __GLASGOW_HASKELL__ > 504 || __GLASGOW_HASKELL__ < 500
- tc_errors e@(IOException ioe) | isUserError ioe = Just e
-#elif __GLASGOW_HASKELL__ == 502
- tc_errors e@(UserError _) = Just e
-#else
- tc_errors e@(IOException ioe) | isUserError e = Just e
-#endif
- tc_errors _other = Nothing
- -- type checker failures show up as UserErrors only
-\end{code}
-
-Lazy interleave
-
-\begin{code}
-unsafeInterleaveM :: TcRn m a -> TcRn m a
-unsafeInterleaveM (TcRn m) = TcRn (\ env -> unsafeInterleaveIO (m env))
-\end{code}
-
-\end{code}
-
-Performing arbitrary I/O, plus the read/write var (for efficiency)
-
-\begin{code}
-ioToTcRn :: IO a -> TcRn m a
-ioToTcRn io = TcRn (\ env -> io)
-
-newMutVar :: a -> TcRn m (TcRef a)
-newMutVar val = TcRn (\ env -> newIORef val)
-
-writeMutVar :: TcRef a -> a -> TcRn m ()
-writeMutVar var val = TcRn (\ env -> writeIORef var val)
-
-readMutVar :: TcRef a -> TcRn m a
-readMutVar var = TcRn (\ env -> readIORef var)
-\end{code}
-
-Getting the environment
-
-\begin{code}
-getEnv :: TcRn m (Env m)
-{-# INLINE getEnv #-}
-getEnv = TcRn (\ env -> return env)
-
-setEnv :: Env n -> TcRn n a -> TcRn m a
-{-# INLINE setEnv #-}
-setEnv new_env (TcRn m) = TcRn (\ env -> m new_env)
-
-updEnv :: (Env m -> Env n) -> TcRn n a -> TcRn m a
-{-# INLINE updEnv #-}
-updEnv upd (TcRn m) = TcRn (\ env -> m (upd env))
-\end{code}
-
-\begin{code}
-zapEnv :: TcRn m a -> TcRn m a
-zapEnv act = TcRn $ \env@Env{ env_top=top, env_gbl=gbl, env_lcl=lcl } ->
- case top of {
- TopEnv{
- top_mode = mode,
- top_dflags = dflags,
- top_hpt = hpt,
- top_eps = eps,
- top_us = us
- } -> do
-
- eps_snap <- readIORef eps
- ref <- newIORef $! emptyExternalPackageState{ eps_PTE = eps_PTE eps_snap }
-
- let
- top' = TopEnv {
- top_mode = mode,
- top_dflags = dflags,
- top_hpt = hpt,
- top_eps = ref,
- top_us = us
- }
-
- type_env = tcg_type_env gbl
- mod = tcg_mod gbl
- gbl' = TcGblEnv {
- tcg_mod = mod,
- tcg_type_env = type_env
- }
-
- env' = Env {
- env_top = top',
- env_gbl = gbl',
- env_lcl = lcl
- -- leave the rest empty
- }
-
- case act of { TcRn f -> f env' }
- }
-\end{code}
-
-%************************************************************************
-%* *