DsMonad.lhs 8.47 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 23
	lookupId,

	dsShadowError,
24
	DsMatchContext(..), DsMatchKind(..), pprDsWarnings
25 26
    ) where

27
IMP_Ubiq()
28 29 30

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

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 =
56 57 58
	UniqSupply
	-> SrcLoc			-- to put in pattern-matching error msgs
	-> (FAST_STRING, FAST_STRING)	-- "module"+"group" : for SCC profiling
59 60 61 62
	-> DsIdEnv
	-> DsWarnings
	-> (result, DsWarnings)

63
type DsWarnings = Bag DsMatchContext	-- The desugarer reports matches which are
64 65 66 67 68 69 70
					-- completely shadowed
{-# INLINE andDs #-}
{-# INLINE thenDs #-}
{-# INLINE returnDs #-}

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

71
initDs  :: UniqSupply
72 73 74 75 76
	-> DsIdEnv
	-> FAST_STRING -- module name: for profiling; (group name: from switches)
	-> DsM a
	-> (a, DsWarnings)

77 78
initDs init_us env mod_name action
  = action init_us mkUnknownSrcLoc module_and_group env emptyBag
79 80
  where
    module_and_group = (mod_name, grp_name)
81
    grp_name  = case opt_SccGroup of
82
		    Just xx -> _PK_ xx
83 84 85 86 87
		    Nothing -> mod_name	-- default: module name

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

88 89 90 91
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}}
92

93 94 95 96
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) ->
97 98 99
    (combiner result1 result2, warns2) }}}

returnDs :: a -> DsM a
100
returnDs result us loc mod_and_grp env warns = (result, warns)
101 102 103 104 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

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)
132
-- Note: crashes if lists not equal length (like zipWithEqual)
133 134 135 136 137 138 139
\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}
140 141 142
newLocalDs :: FAST_STRING -> Type -> DsM Id
newLocalDs nm ty us loc mod_and_grp env warns
  = case (getUnique us) of { assigned_uniq ->
143 144 145 146 147 148 149
    (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
150 151
duplicateLocalDs old_local us loc mod_and_grp env warns
  = case (getUnique us) of { assigned_uniq ->
152 153 154
    (mkIdWithNewUniq old_local assigned_uniq, warns) }

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

\begin{code}
161
newTyVarsDs :: [TyVar] -> DsM [TyVar]
162

163 164
newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
  = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
165
    (zipWithEqual "newTyVarsDs" cloneTyVar tyvar_tmpls uniqs, warns) }
166 167 168 169 170 171 172
\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

173 174
uniqSMtoDsM u_action us loc mod_and_grp env warns
  = (u_action us, warns)
175 176

getSrcLocDs :: DsM (String, String)
177
getSrcLocDs us loc mod_and_grp env warns
178 179 180 181
  = case (unpackSrcLoc loc) of { (x,y) ->
    ((_UNPK_ x, _UNPK_ y), warns) }

putSrcLocDs :: SrcLoc -> DsM a -> DsM a
182 183
putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
  = expr us new_loc mod_and_grp env warns
184 185

dsShadowError :: DsMatchContext -> DsM ()
186
dsShadowError cxt us loc mod_and_grp env warns
187 188 189 190 191
  = ((), warns `snocBag` cxt)
\end{code}

\begin{code}
getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
192
getModuleAndGroupDs us loc mod_and_grp env warns
193 194 195 196
  = (mod_and_grp, warns)
\end{code}

\begin{code}
197
type DsIdEnv = IdEnv CoreExpr
198

199
extendEnvDs :: [(Id, CoreExpr)] -> DsM a -> DsM a
200

201
extendEnvDs pairs then_do us loc mod_and_grp old_env warns
202
  = case splitUniqSupply us 	    of { (s1, s2) ->
203 204 205 206 207
    let
	revised_pairs = subst_all pairs s1
    in
    then_do s2 loc mod_and_grp (growIdEnvList old_env revised_pairs) warns
    }
208
  where
209 210 211 212 213 214 215 216
    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
217 218 219 220 221
  = (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)

222 223
lookupEnvWithDefaultDs :: Id -> CoreExpr -> DsM CoreExpr
lookupEnvWithDefaultDs id deflt us loc mod_and_grp env warns
224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249
  = (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}
data DsMatchContext
  = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
  | NoMatchContext

data DsMatchKind
  = FunMatch Id
  | CaseMatch
  | LambdaMatch
  | PatBindMatch
250
  | DoBindMatch
251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277

pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty
pprDsWarnings sty warns
  = ppAboves (map pp_cxt (bagToList warns))
  where
    pp_cxt NoMatchContext = ppPStr SLIT("Some match is shadowed; I don't know what")
    pp_cxt (DsMatchContext kind pats loc)
      = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")])
	     4 (ppHang (ppPStr SLIT("Pattern match(es) completely overlapped:"))
		     4 (pp_match kind pats))

    pp_match (FunMatch fun) pats
      = ppHang (ppr sty fun)
	4 (ppSep [ppSep (map (ppr sty) pats), ppPStr SLIT("= ...")])

    pp_match CaseMatch pats
      = ppHang (ppPStr SLIT("in a case alternative:"))
	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])

278 279 280 281
    pp_match DoBindMatch pats
      = ppHang (ppPStr SLIT("in a `do' pattern binding:"))
	4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])

282 283
    pp_arrow_dotdotdot = ppPStr SLIT("-> ...")
\end{code}