[project @ 2004-08-16 09:53:47 by simonpj]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsMonad.lhs

diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index 531f729..7605687 100644 (file)
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -11,7 +11,7 @@ module DsMonad (
        newTyVarsDs, 
        duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
        newFailLocalDs,
-       getSrcLocDs, putSrcLocDs,
+       getSrcSpanDs, putSrcSpanDs,
        getModuleDs,
        newUnique, 
        UniqSupply, newUniqueSupply,
@@ -27,9 +27,9 @@ module DsMonad (
 
 #include "HsVersions.h"
 
-import TcHsSyn         ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr )
 import TcRnMonad
-import IfaceEnv                ( tcIfaceGlobal )
+import HsSyn           ( HsExpr, HsMatchContext, Pat )
+import TcIface         ( tcIfaceGlobal )
 import HscTypes                ( TyThing(..), TypeEnv, HscEnv, 
                          IsBootInterface,
                          tyThingId, tyThingTyCon, tyThingDataCon  )
@@ -41,7 +41,7 @@ import Id             ( mkSysLocal, setIdUnique, Id )
 import Module          ( Module, ModuleName, ModuleEnv )
 import Var             ( TyVar, setTyVarUnique )
 import Outputable
-import SrcLoc          ( noSrcLoc, SrcLoc )
+import SrcLoc          ( noSrcSpan, SrcSpan )
 import Type             ( Type )
 import UniqSupply      ( UniqSupply, uniqsFromSupply )
 import Name            ( Name, nameOccName )
@@ -69,7 +69,10 @@ foldlDs  = foldlM
 mapAndUnzipDs = mapAndUnzipM
 
 
-type DsWarning = (SrcLoc, SDoc)
+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.
 
 data DsGblEnv = DsGblEnv {
        ds_mod     :: Module,                   -- For SCC profiling
@@ -80,7 +83,7 @@ data DsGblEnv = DsGblEnv {
 
 data DsLclEnv = DsLclEnv {
        ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
-       ds_loc     :: SrcLoc            -- to put in pattern-matching error msgs
+       ds_loc     :: SrcSpan           -- to put in pattern-matching error msgs
      }
 
 -- Inside [| |] brackets, the desugarer looks 
@@ -92,26 +95,24 @@ data DsMetaVal
                        -- Will be dynamically alpha renamed.
                        -- The Id has type THSyntax.Var
 
-   | Splice TypecheckedHsExpr  -- These bindings are introduced by
-                               -- the PendingSplices on a HsBracketOut
+   | Splice (HsExpr Id)        -- These bindings are introduced by
+                       -- the PendingSplices on a HsBracketOut
 
 -- initDs returns the UniqSupply out the end (not just the result)
 
 initDs  :: HscEnv
        -> Module -> TypeEnv
-       -> ModuleEnv (ModuleName,IsBootInterface)       
        -> DsM a
        -> IO (a, Bag DsWarning)
 
-initDs hsc_env mod type_env is_boot thing_inside
+initDs hsc_env mod type_env thing_inside
   = do         { warn_var <- newIORef emptyBag
-       ; let { if_env = IfGblEnv { if_rec_types = Just (mod, return type_env),
-                                   if_is_boot = is_boot }
+       ; let { if_env = IfGblEnv { if_rec_types = Just (mod, return type_env) }
              ; gbl_env = DsGblEnv { ds_mod = mod, 
                                     ds_if_env = if_env, 
                                     ds_warns = warn_var }
              ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv, 
-                                    ds_loc = noSrcLoc } }
+                                    ds_loc = noSrcSpan } }
 
        ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside
 
@@ -158,7 +159,7 @@ newTyVarsDs tyvar_tmpls
 \end{code}
 
 We can also reach out and either set/grab location information from
-the @SrcLoc@ being carried around.
+the @SrcSpan@ being carried around.
 
 \begin{code}
 getDOptsDs :: DsM DynFlags
@@ -167,11 +168,11 @@ getDOptsDs = getDOpts
 getModuleDs :: DsM Module
 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
 
-getSrcLocDs :: DsM SrcLoc
-getSrcLocDs = do { env <- getLclEnv; return (ds_loc env) }
+getSrcSpanDs :: DsM SrcSpan
+getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
 
-putSrcLocDs :: SrcLoc -> DsM a -> DsM a
-putSrcLocDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
+putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
+putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
 
 dsWarn :: DsWarning -> DsM ()
 dsWarn (loc,warn) = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
@@ -221,7 +222,7 @@ dsExtendMetaEnv menv thing_inside
 
 \begin{code}
 data DsMatchContext
-  = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc
+  = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan
   | NoMatchContext
   deriving ()
 \end{code}