Commit 0eae68cd authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Tabs -> spaces

parent 03d45973
......@@ -7,10 +7,10 @@
\begin{code}
module DsMonad (
DsM, mapM, mapAndUnzipM,
initDs, initDsTc, fixDs,
foldlM, foldrM, ifDOptM, unsetDOptM, unsetWOptM,
Applicative(..),(<$>),
DsM, mapM, mapAndUnzipM,
initDs, initDsTc, fixDs,
foldlM, foldrM, ifDOptM, unsetDOptM, unsetWOptM,
Applicative(..),(<$>),
newLocalName,
duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
......@@ -23,17 +23,17 @@ module DsMonad (
getDOptsDs, getGhcModeDs, doptDs, woptDs,
dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
dsLoadModule,
-- Warnings
DsWarning, warnDs, failWithDs,
-- Warnings
DsWarning, warnDs, failWithDs,
-- Data types
DsMatchContext(..),
EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
CanItFail(..), orFail
-- Data types
DsMatchContext(..),
EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
CanItFail(..), orFail
) where
import TcRnMonad
......@@ -62,9 +62,9 @@ import Data.IORef
\end{code}
%************************************************************************
%* *
Data types for the desugarer
%* *
%* *
Data types for the desugarer
%* *
%************************************************************************
\begin{code}
......@@ -73,8 +73,8 @@ data DsMatchContext
deriving ()
data EquationInfo
= EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
eqn_rhs :: MatchResult } -- What to do after match
= EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
eqn_rhs :: MatchResult } -- What to do after match
instance Outputable EquationInfo where
ppr (EqnInfo pats _) = ppr pats
......@@ -84,18 +84,18 @@ idDsWrapper :: DsWrapper
idDsWrapper e = e
-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
-- \fail. wrap (case vs of { pats -> rhs fail })
-- \fail. wrap (case vs of { pats -> rhs fail })
-- where vs are not bound by wrap
-- A MatchResult is an expression with a hole in it
data MatchResult
= MatchResult
CanItFail -- Tells whether the failure expression is used
(CoreExpr -> DsM CoreExpr)
-- Takes a expression to plug in at the
-- failure point(s). The expression should
-- be duplicatable!
CanItFail -- Tells whether the failure expression is used
(CoreExpr -> DsM CoreExpr)
-- Takes a expression to plug in at the
-- failure point(s). The expression should
-- be duplicatable!
data CanItFail = CanFail | CantFail
......@@ -106,9 +106,9 @@ orFail _ _ = CanFail
%************************************************************************
%* *
Monad stuff
%* *
%* *
Monad stuff
%* *
%************************************************************************
Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
......@@ -122,21 +122,21 @@ fixDs :: (a -> DsM a) -> DsM a
fixDs = fixM
type DsWarning = (SrcSpan, SDoc)
-- Not quite the same as a WarnMsg, we have an SDoc here
-- and we'll do the print_unqual stuff later on to turn it
-- into a Doc.
-- Not quite the same as a WarnMsg, we have an SDoc here
-- and we'll do the print_unqual stuff later on to turn it
-- into a Doc.
data DsGblEnv = DsGblEnv {
ds_mod :: Module, -- For SCC profiling
ds_unqual :: PrintUnqualified,
ds_msgs :: IORef Messages, -- Warning messages
ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
-- possibly-imported things
ds_mod :: Module, -- For SCC profiling
ds_unqual :: PrintUnqualified,
ds_msgs :: IORef Messages, -- Warning messages
ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
-- possibly-imported things
}
data DsLclEnv = DsLclEnv {
ds_meta :: DsMetaEnv, -- Template Haskell bindings
ds_loc :: SrcSpan -- to put in pattern-matching error msgs
ds_meta :: DsMetaEnv, -- Template Haskell bindings
ds_loc :: SrcSpan -- to put in pattern-matching error msgs
}
-- Inside [| |] brackets, the desugarer looks
......@@ -144,51 +144,51 @@ data DsLclEnv = DsLclEnv {
type DsMetaEnv = NameEnv DsMetaVal
data DsMetaVal
= Bound Id -- Bound by a pattern inside the [| |].
-- Will be dynamically alpha renamed.
-- The Id has type THSyntax.Var
= Bound Id -- Bound by a pattern inside the [| |].
-- Will be dynamically alpha renamed.
-- The Id has type THSyntax.Var
| Splice (HsExpr Id) -- These bindings are introduced by
-- the PendingSplices on a HsBracketOut
| Splice (HsExpr Id) -- These bindings are introduced by
-- the PendingSplices on a HsBracketOut
initDs :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> DsM a
-> IO (Messages, Maybe a)
-> Module -> GlobalRdrEnv -> TypeEnv
-> DsM a
-> IO (Messages, Maybe a)
-- Print errors and warnings, if any arise
initDs hsc_env mod rdr_env type_env thing_inside
= do { msg_var <- newIORef (emptyBag, emptyBag)
; let dflags = hsc_dflags hsc_env
= do { msg_var <- newIORef (emptyBag, emptyBag)
; let dflags = hsc_dflags hsc_env
; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs dflags mod rdr_env type_env msg_var
; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
tryM thing_inside -- Catch exceptions (= errors during desugaring)
; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
tryM thing_inside -- Catch exceptions (= errors during desugaring)
-- Display any errors and warnings
-- Note: if -Werror is used, we don't signal an error here.
; msgs <- readIORef msg_var
-- Display any errors and warnings
-- Note: if -Werror is used, we don't signal an error here.
; msgs <- readIORef msg_var
; let final_res | errorsFound dflags msgs = Nothing
| otherwise = case either_res of
Right res -> Just res
Left exn -> pprPanic "initDs" (text (show exn))
-- The (Left exn) case happens when the thing_inside throws
-- a UserError exception. Then it should have put an error
-- message in msg_var, so we just discard the exception
; let final_res | errorsFound dflags msgs = Nothing
| otherwise = case either_res of
Right res -> Just res
Left exn -> pprPanic "initDs" (text (show exn))
-- The (Left exn) case happens when the thing_inside throws
-- a UserError exception. Then it should have put an error
-- message in msg_var, so we just discard the exception
; return (msgs, final_res) }
; return (msgs, final_res) }
initDsTc :: DsM a -> TcM a
initDsTc thing_inside
= do { this_mod <- getModule
; tcg_env <- getGblEnv
; msg_var <- getErrsVar
= do { this_mod <- getModule
; tcg_env <- getGblEnv
; msg_var <- getErrsVar
; dflags <- getDOpts
; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
; ds_envs <- liftIO $ mkDsEnvs dflags this_mod rdr_env type_env msg_var
; setEnvs ds_envs thing_inside }
; setEnvs ds_envs thing_inside }
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env msg_var
......@@ -196,19 +196,19 @@ mkDsEnvs dflags mod rdr_env type_env msg_var
let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
gbl_env = DsGblEnv { ds_mod = mod,
ds_if_env = (if_genv, if_lenv),
ds_unqual = mkPrintUnqualified dflags rdr_env,
ds_msgs = msg_var}
ds_if_env = (if_genv, if_lenv),
ds_unqual = mkPrintUnqualified dflags rdr_env,
ds_msgs = msg_var}
lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
ds_loc = noSrcSpan }
ds_loc = noSrcSpan }
return (gbl_env, lcl_env)
\end{code}
%************************************************************************
%* *
Operations in the monad
%* *
%* *
Operations in the monad
%* *
%************************************************************************
And all this mysterious stuff is so we can occasionally reach out and
......@@ -223,8 +223,8 @@ newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id)))
duplicateLocalDs :: Id -> DsM Id
duplicateLocalDs old_local
= do { uniq <- newUnique
; return (setIdUnique old_local uniq) }
= do { uniq <- newUnique
; return (setIdUnique old_local uniq) }
newPredVarDs :: PredType -> DsM Var
newPredVarDs pred
......@@ -265,18 +265,18 @@ putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc})
warnDs :: SDoc -> DsM ()
warnDs warn = do { env <- getGblEnv
; loc <- getSrcSpanDs
; let msg = mkWarnMsg loc (ds_unqual env)
(ptext (sLit "Warning:") <+> warn)
; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
; loc <- getSrcSpanDs
; let msg = mkWarnMsg loc (ds_unqual env)
(ptext (sLit "Warning:") <+> warn)
; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
failWithDs :: SDoc -> DsM a
failWithDs err
= do { env <- getGblEnv
; loc <- getSrcSpanDs
; let msg = mkErrMsg loc (ds_unqual env) err
; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
; failM }
= do { env <- getGblEnv
; loc <- getSrcSpanDs
; let msg = mkErrMsg loc (ds_unqual env) err
; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
; failM }
mkPrintUnqualifiedDs :: DsM PrintUnqualified
mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
......@@ -289,9 +289,9 @@ instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
dsLookupGlobal :: Name -> DsM TyThing
-- Very like TcEnv.tcLookupGlobal
dsLookupGlobal name
= do { env <- getGblEnv
; setEnvs (ds_if_env env)
(tcIfaceGlobal name) }
= do { env <- getGblEnv
; setEnvs (ds_if_env env)
(tcIfaceGlobal name) }
dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId name
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment