[project @ 1996-06-30 15:56:44 by partain]

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

diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index 2900230..3ea0bc2 100644 (file)
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -7,7 +7,7 @@
 #include "HsVersions.h"
 
 module DsMonad (
-       DsM(..),
+       SYN_IE(DsM),
        initDs, returnDs, thenDs, andDs, mapDs, listDs,
        mapAndUnzipDs, zipWithDs,
        uniqSMtoDsM,
@@ -17,32 +17,32 @@ module DsMonad (
        getSrcLocDs, putSrcLocDs,
        getModuleAndGroupDs,
        extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs,
-       DsIdEnv(..),
+       SYN_IE(DsIdEnv),
        lookupId,
 
        dsShadowError,
        DsMatchContext(..), DsMatchKind(..), pprDsWarnings
     ) where
 
-import Ubiq
+IMP_Ubiq()
 
 import Bag             ( emptyBag, snocBag, bagToList )
 import CmdLineOpts     ( opt_SccGroup )
-import CoreSyn         ( CoreExpr(..) )
+import CoreSyn         ( SYN_IE(CoreExpr) )
 import CoreUtils       ( substCoreExpr )
 import HsSyn           ( OutPat )
 import Id              ( mkSysLocal, mkIdWithNewUniq,
-                         lookupIdEnv, growIdEnvList, GenId, IdEnv(..)
+                         lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv)
                        )
 import PprType         ( GenType, GenTyVar )
 import PprStyle                ( PprStyle(..) )
 import Pretty
 import SrcLoc          ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc )
-import TcHsSyn         ( TypecheckedPat(..) )
+import TcHsSyn         ( SYN_IE(TypecheckedPat) )
 import TyVar           ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} )
 import Unique          ( Unique{-instances-} )
 import UniqSupply      ( splitUniqSupply, getUnique, getUniques,
-                         mapUs, thenUs, returnUs, UniqSM(..) )
+                         mapUs, thenUs, returnUs, SYN_IE(UniqSM) )
 import Util            ( assoc, mapAccumL, zipWithEqual, panic )
 
 infixr 9 `thenDs`
@@ -154,7 +154,7 @@ duplicateLocalDs old_local us loc mod_and_grp env warns
 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
 cloneTyVarsDs tyvars us loc mod_and_grp env warns
   = case (getUniques (length tyvars) us) of { uniqs ->
-    (zipWithEqual cloneTyVar tyvars uniqs, warns) }
+    (zipWithEqual "cloneTyVarsDs" cloneTyVar tyvars uniqs, warns) }
 \end{code}
 
 \begin{code}
@@ -162,7 +162,7 @@ newTyVarsDs :: [TyVar] -> DsM [TyVar]
 
 newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
   = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
-    (zipWithEqual cloneTyVar tyvar_tmpls uniqs, warns) }
+    (zipWithEqual "newTyVarsDs" cloneTyVar tyvar_tmpls uniqs, warns) }
 \end{code}
 
 We can also reach out and either set/grab location information from
@@ -247,6 +247,7 @@ data DsMatchKind
   | CaseMatch
   | LambdaMatch
   | PatBindMatch
+  | DoBindMatch
 
 pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty
 pprDsWarnings sty warns
@@ -274,5 +275,9 @@ pprDsWarnings sty warns
       = ppHang (ppPStr SLIT("in a lambda abstraction:"))
        4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
 
+    pp_match DoBindMatch pats
+      = ppHang (ppPStr SLIT("in a `do' pattern binding:"))
+       4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
+
     pp_arrow_dotdotdot = ppPStr SLIT("-> ...")
 \end{code}