DsMonad.lhs 9 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3
%
4
\section[DsMonad]{@DsMonad@: monadery used in desugaring}
5 6 7 8 9

\begin{code}
#include "HsVersions.h"

module DsMonad (
10
	SYN_IE(DsM),
11 12 13 14 15 16 17 18 19
	initDs, returnDs, thenDs, andDs, mapDs, listDs,
	mapAndUnzipDs, zipWithDs,
	uniqSMtoDsM,
	newTyVarsDs, cloneTyVarsDs,
	duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
	newFailLocalDs,
	getSrcLocDs, putSrcLocDs,
	getModuleAndGroupDs,
	extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs,
20
	SYN_IE(DsIdEnv),
21 22
	lookupId,

23 24 25 26 27
	dsShadowWarn, dsIncompleteWarn,
	DsWarnings(..),
	DsMatchContext(..), DsMatchKind(..), pprDsWarnings,
        DsWarnFlavour -- Nuke with 1.4

28 29
    ) where

30
IMP_Ubiq()
31 32 33

import Bag		( emptyBag, snocBag, bagToList )
import CmdLineOpts	( opt_SccGroup )
34
import CoreSyn		( SYN_IE(CoreExpr) )
35 36
import CoreUtils	( substCoreExpr )
import HsSyn		( OutPat )
37
import Id		( mkSysLocal, mkIdWithNewUniq,
38
			  lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv)
39
			)
40 41
import PprType		( GenType, GenTyVar )
import PprStyle		( PprStyle(..) )
42
import Pretty
43
import SrcLoc		( noSrcLoc, SrcLoc )
44
import TcHsSyn		( SYN_IE(TypecheckedPat) )
45
import TyVar		( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} )
46 47
import Unique		( Unique{-instances-} )
import UniqSupply	( splitUniqSupply, getUnique, getUniques,
48
			  mapUs, thenUs, returnUs, SYN_IE(UniqSM) )
49
import Util		( assoc, mapAccumL, zipWithEqual, panic )
50 51 52 53 54 55 56 57 58

infixr 9 `thenDs`
\end{code}

Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
a @UniqueSupply@ and some annotations, which
presumably include source-file location information:
\begin{code}
type DsM result =
59 60 61
	UniqSupply
	-> SrcLoc			-- to put in pattern-matching error msgs
	-> (FAST_STRING, FAST_STRING)	-- "module"+"group" : for SCC profiling
62 63 64 65
	-> DsIdEnv
	-> DsWarnings
	-> (result, DsWarnings)

66 67 68
type DsWarnings = Bag (DsWarnFlavour, DsMatchContext)
					-- The desugarer reports matches which are
					-- completely shadowed or incomplete patterns
69 70 71 72 73 74
{-# INLINE andDs #-}
{-# INLINE thenDs #-}
{-# INLINE returnDs #-}

-- initDs returns the UniqSupply out the end (not just the result)

75
initDs  :: UniqSupply
76 77 78 79 80
	-> DsIdEnv
	-> FAST_STRING -- module name: for profiling; (group name: from switches)
	-> DsM a
	-> (a, DsWarnings)

81
initDs init_us env mod_name action
82
  = action init_us noSrcLoc module_and_group env emptyBag
83 84
  where
    module_and_group = (mod_name, grp_name)
85
    grp_name  = case opt_SccGroup of
86
		    Just xx -> _PK_ xx
87 88 89 90 91
		    Nothing -> mod_name	-- default: module name

thenDs :: DsM a -> (a -> DsM b) -> DsM b
andDs  :: (a -> a -> a) -> DsM a -> DsM a -> DsM a

92 93 94 95
thenDs m1 m2 us loc mod_and_grp env warns
  = case splitUniqSupply us		    of { (s1, s2) ->
    case (m1 s1 loc mod_and_grp env warns)  of { (result, warns1) ->
    m2 result s2 loc mod_and_grp env warns1}}
96

97 98 99 100
andDs combiner m1 m2 us loc mod_and_grp env warns
  = case splitUniqSupply us		    of { (s1, s2) ->
    case (m1 s1 loc mod_and_grp env warns)  of { (result1, warns1) ->
    case (m2 s2 loc mod_and_grp env warns1) of { (result2, warns2) ->
101 102 103
    (combiner result1 result2, warns2) }}}

returnDs :: a -> DsM a
104
returnDs result us loc mod_and_grp env warns = (result, warns)
105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135

listDs :: [DsM a] -> DsM [a]
listDs []     = returnDs []
listDs (x:xs)
  = x		`thenDs` \ r  ->
    listDs xs	`thenDs` \ rs ->
    returnDs (r:rs)

mapDs :: (a -> DsM b) -> [a] -> DsM [b]

mapDs f []     = returnDs []
mapDs f (x:xs)
  = f x		`thenDs` \ r  ->
    mapDs f xs	`thenDs` \ rs ->
    returnDs (r:rs)

mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])

mapAndUnzipDs f []     = returnDs ([], [])
mapAndUnzipDs f (x:xs)
  = f x		    	`thenDs` \ (r1, r2)  ->
    mapAndUnzipDs f xs	`thenDs` \ (rs1, rs2) ->
    returnDs (r1:rs1, r2:rs2)

zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]

zipWithDs f []	   [] = returnDs []
zipWithDs f (x:xs) (y:ys)
  = f x y		`thenDs` \ r  ->
    zipWithDs f xs ys	`thenDs` \ rs ->
    returnDs (r:rs)
136
-- Note: crashes if lists not equal length (like zipWithEqual)
137 138 139 140 141 142 143
\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}
144 145 146
newLocalDs :: FAST_STRING -> Type -> DsM Id
newLocalDs nm ty us loc mod_and_grp env warns
  = case (getUnique us) of { assigned_uniq ->
147 148 149 150 151 152 153
    (mkSysLocal nm assigned_uniq ty loc, warns) }

newSysLocalDs	    = newLocalDs SLIT("ds")
newSysLocalsDs tys  = mapDs (newLocalDs SLIT("ds")) tys
newFailLocalDs	    = newLocalDs SLIT("fail")

duplicateLocalDs :: Id -> DsM Id
154 155
duplicateLocalDs old_local us loc mod_and_grp env warns
  = case (getUnique us) of { assigned_uniq ->
156 157 158
    (mkIdWithNewUniq old_local assigned_uniq, warns) }

cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
159 160
cloneTyVarsDs tyvars us loc mod_and_grp env warns
  = case (getUniques (length tyvars) us) of { uniqs ->
161
    (zipWithEqual "cloneTyVarsDs" cloneTyVar tyvars uniqs, warns) }
162 163 164
\end{code}

\begin{code}
165
newTyVarsDs :: [TyVar] -> DsM [TyVar]
166

167 168
newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
  = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
169
    (zipWithEqual "newTyVarsDs" cloneTyVar tyvar_tmpls uniqs, warns) }
170 171 172 173 174 175 176
\end{code}

We can also reach out and either set/grab location information from
the @SrcLoc@ being carried around.
\begin{code}
uniqSMtoDsM :: UniqSM a -> DsM a

177 178
uniqSMtoDsM u_action us loc mod_and_grp env warns
  = (u_action us, warns)
179

180
getSrcLocDs :: DsM SrcLoc
181
getSrcLocDs us loc mod_and_grp env warns
182
  = (loc, warns)
183 184

putSrcLocDs :: SrcLoc -> DsM a -> DsM a
185 186
putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
  = expr us new_loc mod_and_grp env warns
187

188 189 190 191 192 193 194
dsShadowWarn :: DsMatchContext -> DsM ()
dsShadowWarn cxt us loc mod_and_grp env warns
  = ((), warns `snocBag` (Shadowed, cxt))

dsIncompleteWarn :: DsMatchContext -> DsM ()
dsIncompleteWarn cxt us loc mod_and_grp env warns
  = ((), warns `snocBag` (Incomplete, cxt))
195 196 197 198
\end{code}

\begin{code}
getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
199
getModuleAndGroupDs us loc mod_and_grp env warns
200 201 202 203
  = (mod_and_grp, warns)
\end{code}

\begin{code}
204
type DsIdEnv = IdEnv CoreExpr
205

206
extendEnvDs :: [(Id, CoreExpr)] -> DsM a -> DsM a
207

208
extendEnvDs pairs then_do us loc mod_and_grp old_env warns
209
  = case splitUniqSupply us 	    of { (s1, s2) ->
210 211 212 213 214
    let
	revised_pairs = subst_all pairs s1
    in
    then_do s2 loc mod_and_grp (growIdEnvList old_env revised_pairs) warns
    }
215
  where
216 217 218 219 220 221 222 223
    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
224 225 226 227 228
  = (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)

229 230
lookupEnvWithDefaultDs :: Id -> CoreExpr -> DsM CoreExpr
lookupEnvWithDefaultDs id deflt us loc mod_and_grp env warns
231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247
  = (case (lookupIdEnv env id) of
      Nothing -> deflt
      Just xx -> xx,
     warns)

lookupId :: [(Id, a)] -> Id -> a
lookupId env id
  = assoc "lookupId" env id
\end{code}

%************************************************************************
%*									*
%* type synonym EquationInfo and access functions for its pieces	*
%*									*
%************************************************************************

\begin{code}
248 249
data DsWarnFlavour = Shadowed | Incomplete deriving ()

250 251 252
data DsMatchContext
  = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
  | NoMatchContext
253
  deriving ()
254 255 256 257 258 259

data DsMatchKind
  = FunMatch Id
  | CaseMatch
  | LambdaMatch
  | PatBindMatch
260
  | DoBindMatch
261
  deriving ()
262

263
pprDsWarnings :: PprStyle -> DsWarnings -> Pretty
264
pprDsWarnings sty warns
265
  = ppAboves (map pp_warn (bagToList warns))
266
  where
267 268 269 270 271 272 273 274
    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
275
		     4 (pp_match kind pats))
276 277 278 279
       where
	msg = case flavour of
		Shadowed   -> ppPStr SLIT("Warning: Pattern match(es) completely overlapped")     
		Incomplete -> ppPStr SLIT("Warning: Possibly incomplete patterns")
280 281

    pp_match (FunMatch fun) pats
282
      = ppCat [ppPStr SLIT("in the definition of function"), ppQuote (ppr sty fun)]
283 284

    pp_match CaseMatch pats
285
      = ppHang (ppPStr SLIT("in a group of case alternatives beginning:"))
286 287 288 289 290 291 292 293 294 295
	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])

296 297 298 299
    pp_match DoBindMatch pats
      = ppHang (ppPStr SLIT("in a `do' pattern binding:"))
	4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])

300 301
    pp_arrow_dotdotdot = ppPStr SLIT("-> ...")
\end{code}