X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMonad.lhs;h=19a4c33b40e6faba0eec9115cbd251b222df7b35;hb=f36fb2ce821caf594c1db5669dd10ca082f66361;hp=c2034d75e5cc046f88eb8dd3b58784fcecb16a1c;hpb=2494407a750053daa61718fac371487d04818e57;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index c2034d7..19a4c33 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -4,10 +4,8 @@
 \section[DsMonad]{@DsMonad@: monadery used in desugaring}
 
 \begin{code}
-#include "HsVersions.h"
-
 module DsMonad (
-	SYN_IE(DsM),
+	DsM,
 	initDs, returnDs, thenDs, andDs, mapDs, listDs,
 	mapAndUnzipDs, zipWithDs,
 	uniqSMtoDsM,
@@ -16,37 +14,32 @@ module DsMonad (
 	newFailLocalDs,
 	getSrcLocDs, putSrcLocDs,
 	getModuleAndGroupDs,
-	extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs,
-	SYN_IE(DsIdEnv),
-	lookupId,
-
-	dsShadowWarn, dsIncompleteWarn,
-	DsWarnings(..),
-	DsMatchContext(..), DsMatchKind(..), pprDsWarnings,
-        DsWarnFlavour -- Nuke with 1.4
+	extendEnvDs, lookupEnvDs, 
+	DsIdEnv,
 
+	dsWarn, 
+	DsWarnings,
+	DsMatchContext(..), DsMatchKind(..), pprDsWarnings
     ) where
 
-IMP_Ubiq()
+#include "HsVersions.h"
 
-import Bag		( emptyBag, snocBag, bagToList )
-import CmdLineOpts	( opt_SccGroup )
-import CoreSyn		( SYN_IE(CoreExpr) )
-import CoreUtils	( substCoreExpr )
+import Bag		( emptyBag, snocBag, bagToList, Bag )
+import BasicTypes       ( Module )
+import ErrUtils 	( WarnMsg )
 import HsSyn		( OutPat )
-import Id		( mkSysLocal, mkIdWithNewUniq,
-			  lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv)
+import MkId		( mkSysLocal )
+import Id		( mkIdWithNewUniq,
+			  lookupIdEnv, growIdEnvList, IdEnv, Id
 			)
-import PprType		( GenType, GenTyVar )
-import PprStyle		( PprStyle(..) )
-import Pretty
+import Outputable
 import SrcLoc		( noSrcLoc, SrcLoc )
-import TcHsSyn		( SYN_IE(TypecheckedPat) )
-import TyVar		( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} )
-import Unique		( Unique{-instances-} )
+import TcHsSyn		( TypecheckedPat )
+import Type             ( Type )
+import TyVar		( cloneTyVar, TyVar )
 import UniqSupply	( splitUniqSupply, getUnique, getUniques,
-			  mapUs, thenUs, returnUs, SYN_IE(UniqSM) )
-import Util		( assoc, mapAccumL, zipWithEqual, panic )
+			  UniqSM, UniqSupply )
+import Util		( zipWithEqual, panic )
 
 infixr 9 `thenDs`
 \end{code}
@@ -57,15 +50,17 @@ presumably include source-file location information:
 \begin{code}
 type DsM result =
 	UniqSupply
-	-> SrcLoc			-- to put in pattern-matching error msgs
-	-> (FAST_STRING, FAST_STRING)	-- "module"+"group" : for SCC profiling
+	-> SrcLoc		 -- to put in pattern-matching error msgs
+	-> (Module, Group)       -- module + group name : for SCC profiling
 	-> DsIdEnv
 	-> DsWarnings
 	-> (result, DsWarnings)
 
-type DsWarnings = Bag (DsWarnFlavour, DsMatchContext)
-					-- The desugarer reports matches which are
+type DsWarnings = Bag WarnMsg           -- The desugarer reports matches which are
 					-- completely shadowed or incomplete patterns
+
+type Group = FAST_STRING
+
 {-# INLINE andDs #-}
 {-# INLINE thenDs #-}
 {-# INLINE returnDs #-}
@@ -74,17 +69,12 @@ type DsWarnings = Bag (DsWarnFlavour, DsMatchContext)
 
 initDs  :: UniqSupply
 	-> DsIdEnv
-	-> FAST_STRING -- module name: for profiling; (group name: from switches)
+	-> (Module, Group)      -- module name: for profiling; (group name: from switches)
 	-> DsM a
 	-> (a, DsWarnings)
 
-initDs init_us env mod_name action
+initDs init_us env module_and_group action
   = action init_us noSrcLoc module_and_group env emptyBag
-  where
-    module_and_group = (mod_name, grp_name)
-    grp_name  = case opt_SccGroup of
-		    Just xx -> _PK_ xx
-		    Nothing -> mod_name	-- default: module name
 
 thenDs :: DsM a -> (a -> DsM b) -> DsM b
 andDs  :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
@@ -128,18 +118,18 @@ mapAndUnzipDs f (x:xs)
 
 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
 
-zipWithDs f []	   [] = returnDs []
+zipWithDs f []	   ys = returnDs []
 zipWithDs f (x:xs) (y:ys)
   = f x y		`thenDs` \ r  ->
     zipWithDs f xs ys	`thenDs` \ rs ->
     returnDs (r:rs)
--- Note: crashes if lists not equal length (like zipWithEqual)
 \end{code}
 
 And all this mysterious stuff is so we can occasionally reach out and
 grab one or more names.  @newLocalDs@ isn't exported---exported
 functions are defined with it.  The difference in name-strings makes
 it easier to read debugging output.
+
 \begin{code}
 newLocalDs :: FAST_STRING -> Type -> DsM Id
 newLocalDs nm ty us loc mod_and_grp env warns
@@ -185,13 +175,9 @@ putSrcLocDs :: SrcLoc -> DsM a -> DsM a
 putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
   = expr us new_loc mod_and_grp env warns
 
-dsShadowWarn :: DsMatchContext -> DsM ()
-dsShadowWarn cxt us loc mod_and_grp env warns
-  = ((), warns `snocBag` (Shadowed, cxt))
+dsWarn :: WarnMsg -> DsM ()
+dsWarn warn us loc mod_and_grp env warns = ((), warns `snocBag` warn)
 
-dsIncompleteWarn :: DsMatchContext -> DsM ()
-dsIncompleteWarn cxt us loc mod_and_grp env warns
-  = ((), warns `snocBag` (Incomplete, cxt))
 \end{code}
 
 \begin{code}
@@ -201,41 +187,19 @@ getModuleAndGroupDs us loc mod_and_grp env warns
 \end{code}
 
 \begin{code}
-type DsIdEnv = IdEnv CoreExpr
+type DsIdEnv = IdEnv Id
 
-extendEnvDs :: [(Id, CoreExpr)] -> DsM a -> DsM a
+extendEnvDs :: [(Id, Id)] -> DsM a -> DsM a
 
 extendEnvDs pairs then_do us loc mod_and_grp old_env warns
-  = case splitUniqSupply us 	    of { (s1, s2) ->
-    let
-	revised_pairs = subst_all pairs s1
-    in
-    then_do s2 loc mod_and_grp (growIdEnvList old_env revised_pairs) warns
-    }
-  where
-    subst_all pairs = mapUs subst pairs
-
-    subst (v, expr)
-      = substCoreExpr old_env nullTyVarEnv expr `thenUs` \ new_expr ->
-	returnUs (v, new_expr)
-
-lookupEnvDs :: Id -> DsM (Maybe CoreExpr)
-lookupEnvDs id us loc mod_and_grp env warns
-  = (lookupIdEnv env id, warns)
-  -- Note: we don't assert anything about the Id
-  -- being looked up.  There's not really anything
-  -- much to say about it. (WDP 94/06)
+  = then_do us loc mod_and_grp (growIdEnvList old_env pairs) warns
 
-lookupEnvWithDefaultDs :: Id -> CoreExpr -> DsM CoreExpr
-lookupEnvWithDefaultDs id deflt us loc mod_and_grp env warns
+lookupEnvDs :: Id -> DsM Id
+lookupEnvDs id us loc mod_and_grp env warns
   = (case (lookupIdEnv env id) of
-      Nothing -> deflt
+      Nothing -> id
       Just xx -> xx,
      warns)
-
-lookupId :: [(Id, a)] -> Id -> a
-lookupId env id
-  = assoc "lookupId" env id
 \end{code}
 
 %************************************************************************
@@ -245,8 +209,6 @@ lookupId env id
 %************************************************************************
 
 \begin{code}
-data DsWarnFlavour = Shadowed | Incomplete deriving ()
-
 data DsMatchContext
   = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
   | NoMatchContext
@@ -258,44 +220,10 @@ data DsMatchKind
   | LambdaMatch
   | PatBindMatch
   | DoBindMatch
+  | ListCompMatch
+  | LetMatch
   deriving ()
 
-pprDsWarnings :: PprStyle -> DsWarnings -> Pretty
-pprDsWarnings sty warns
-  = ppAboves (map pp_warn (bagToList warns))
-  where
-    pp_warn (flavour, NoMatchContext) = ppSep [ppPStr SLIT("Warning: Some match is"), 
-					       case flavour of
-							Shadowed   -> ppPStr SLIT("shadowed")
-							Incomplete -> ppPStr SLIT("possibly incomplete")]
-
-    pp_warn (flavour, DsMatchContext kind pats loc)
-       = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")])
-	     4 (ppHang msg
-		     4 (pp_match kind pats))
-       where
-	msg = case flavour of
-		Shadowed   -> ppPStr SLIT("Warning: Pattern match(es) completely overlapped")     
-		Incomplete -> ppPStr SLIT("Warning: Possibly incomplete patterns")
-
-    pp_match (FunMatch fun) pats
-      = ppCat [ppPStr SLIT("in the definition of function"), ppQuote (ppr sty fun)]
-
-    pp_match CaseMatch pats
-      = ppHang (ppPStr SLIT("in a group of case alternatives beginning:"))
-	4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
-
-    pp_match PatBindMatch pats
-      = ppHang (ppPStr SLIT("in a pattern binding:"))
-	4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
-
-    pp_match LambdaMatch pats
-      = 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("-> ...")
+pprDsWarnings :: DsWarnings -> SDoc
+pprDsWarnings warns = vcat (bagToList warns)
 \end{code}