\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,
getSrcLocDs, putSrcLocDs,
getModuleAndGroupDs,
extendEnvDs, lookupEnvDs,
- SYN_IE(DsIdEnv),
-
- dsShadowWarn, dsIncompleteWarn,
- SYN_IE(DsWarnings),
- DsMatchContext(..), DsMatchKind(..), pprDsWarnings,
- DsWarnFlavour -- Nuke with 1.4
+ DsIdEnv,
+ dsWarn,
+ DsWarnings,
+ DsMatchContext(..), DsMatchKind(..), pprDsWarnings
) where
-IMP_Ubiq()
+#include "HsVersions.h"
import Bag ( emptyBag, snocBag, bagToList, Bag )
-import CmdLineOpts ( opt_SccGroup, opt_PprUserLength )
-import CoreSyn ( SYN_IE(CoreExpr) )
-import CoreUtils ( substCoreExpr )
+import BasicTypes ( Module )
+import ErrUtils ( WarnMsg )
import HsSyn ( OutPat )
-import Id ( mkSysLocal, mkIdWithNewUniq,
- lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv),
- SYN_IE(Id)
+import MkId ( mkSysLocal )
+import Id ( mkIdWithNewUniq,
+ lookupIdEnv, growIdEnvList, IdEnv, Id
)
-import PprType ( GenType, GenTyVar )
-import Outputable ( pprQuote, Outputable(..), PprStyle(..) )
-import Pretty
+import Outputable
import SrcLoc ( noSrcLoc, SrcLoc )
-import TcHsSyn ( SYN_IE(TypecheckedPat) )
-import Type ( SYN_IE(Type) )
-import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
-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),
- UniqSupply )
-import Util ( assoc, mapAccumL, zipWithEqual, panic )
+ UniqSM, UniqSupply )
+import Util ( zipWithEqual, panic )
infixr 9 `thenDs`
\end{code}
\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 #-}
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
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}
%************************************************************************
\begin{code}
-data DsWarnFlavour = Shadowed | Incomplete deriving ()
-
data DsMatchContext
= DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
| NoMatchContext
| LambdaMatch
| PatBindMatch
| DoBindMatch
+ | ListCompMatch
+ | LetMatch
deriving ()
-pprDsWarnings :: PprStyle -> DsWarnings -> Doc
-pprDsWarnings sty warns
- = vcat (map pp_warn (bagToList warns))
- where
- pp_warn (flavour, NoMatchContext) = sep [ptext SLIT("Warning: Some match is"),
- case flavour of
- Shadowed -> ptext SLIT("shadowed")
- Incomplete -> ptext SLIT("possibly incomplete")]
-
- pp_warn (flavour, DsMatchContext kind pats loc)
- = hang (hcat [ppr (PprForUser opt_PprUserLength) loc, ptext SLIT(": ")])
- 4 (hang msg
- 4 (pp_match kind pats))
- where
- msg = case flavour of
- Shadowed -> ptext SLIT("Warning: Pattern match(es) completely overlapped")
- Incomplete -> ptext SLIT("Warning: Possibly incomplete patterns")
-
- pp_match (FunMatch fun) pats
- = hsep [ptext SLIT("in the definition of function"), ppr sty fun]
-
- pp_match CaseMatch pats
- = hang (ptext SLIT("in a group of case alternatives beginning:"))
- 4 (ppr_pats pats)
-
- pp_match PatBindMatch pats
- = hang (ptext SLIT("in a pattern binding:"))
- 4 (ppr_pats pats)
-
- pp_match LambdaMatch pats
- = hang (ptext SLIT("in a lambda abstraction:"))
- 4 (ppr_pats pats)
-
- pp_match DoBindMatch pats
- = hang (ptext SLIT("in a `do' pattern binding:"))
- 4 (ppr_pats pats)
-
- ppr_pats pats = pprQuote sty $ \ sty ->
- sep [sep (map (ppr sty) pats), ptext SLIT("-> ...")]
+pprDsWarnings :: DsWarnings -> SDoc
+pprDsWarnings warns = vcat (bagToList warns)
\end{code}
projects / ghc-hetmet.git / blobdiff