Major Overhaul of Pattern Match Checking (Fixes #595)
[ghc.git] / compiler / deSugar / DsMonad.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 @DsMonad@: monadery used in desugaring
7 -}
8
9 {-# LANGUAGE FlexibleInstances #-}
10 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan
11
12 module DsMonad (
13 DsM, mapM, mapAndUnzipM,
14 initDs, initDsTc, initTcDsForSolver, fixDs,
15 foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM,
16 Applicative(..),(<$>),
17
18 newLocalName,
19 duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
20 newFailLocalDs, newPredVarDs,
21 getSrcSpanDs, putSrcSpanDs,
22 mkPrintUnqualifiedDs,
23 newUnique,
24 UniqSupply, newUniqueSupply,
25 getGhcModeDs, dsGetFamInstEnvs, dsGetStaticBindsVar,
26 dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
27
28 PArrBuiltin(..),
29 dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe,
30 dsInitPArrBuiltin,
31
32 DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
33
34 -- Getting and setting EvVars and term constraints in local environment
35 getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,
36
37 -- Warnings
38 DsWarning, warnDs, failWithDs, discardWarningsDs,
39
40 -- Data types
41 DsMatchContext(..),
42 EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
43 CanItFail(..), orFail
44 ) where
45
46 import TcRnMonad
47 import FamInstEnv
48 import CoreSyn
49 import HsSyn
50 import TcIface
51 import LoadIface
52 import Finder
53 import PrelNames
54 import RnNames
55 import RdrName
56 import HscTypes
57 import Bag
58 import DataCon
59 import TyCon
60 import PmExpr
61 import Id
62 import Module
63 import Outputable
64 import SrcLoc
65 import Type
66 import UniqSupply
67 import Name
68 import NameEnv
69 import DynFlags
70 import ErrUtils
71 import FastString
72 import Maybes
73 import Var (EvVar)
74 import GHC.Fingerprint
75
76 import Data.IORef
77 import Control.Monad
78
79 {-
80 ************************************************************************
81 * *
82 Data types for the desugarer
83 * *
84 ************************************************************************
85 -}
86
87 data DsMatchContext
88 = DsMatchContext (HsMatchContext Name) SrcSpan
89 deriving ()
90
91 data EquationInfo
92 = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
93 eqn_rhs :: MatchResult } -- What to do after match
94
95 instance Outputable EquationInfo where
96 ppr (EqnInfo pats _) = ppr pats
97
98 type DsWrapper = CoreExpr -> CoreExpr
99 idDsWrapper :: DsWrapper
100 idDsWrapper e = e
101
102 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
103 -- \fail. wrap (case vs of { pats -> rhs fail })
104 -- where vs are not bound by wrap
105
106
107 -- A MatchResult is an expression with a hole in it
108 data MatchResult
109 = MatchResult
110 CanItFail -- Tells whether the failure expression is used
111 (CoreExpr -> DsM CoreExpr)
112 -- Takes a expression to plug in at the
113 -- failure point(s). The expression should
114 -- be duplicatable!
115
116 data CanItFail = CanFail | CantFail
117
118 orFail :: CanItFail -> CanItFail -> CanItFail
119 orFail CantFail CantFail = CantFail
120 orFail _ _ = CanFail
121
122 {-
123 ************************************************************************
124 * *
125 Monad functions
126 * *
127 ************************************************************************
128 -}
129
130 -- Compatibility functions
131 fixDs :: (a -> DsM a) -> DsM a
132 fixDs = fixM
133
134 type DsWarning = (SrcSpan, SDoc)
135 -- Not quite the same as a WarnMsg, we have an SDoc here
136 -- and we'll do the print_unqual stuff later on to turn it
137 -- into a Doc.
138
139 initDs :: HscEnv
140 -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
141 -> DsM a
142 -> IO (Messages, Maybe a)
143 -- Print errors and warnings, if any arise
144
145 initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
146 = do { msg_var <- newIORef (emptyBag, emptyBag)
147 ; static_binds_var <- newIORef []
148 ; let dflags = hsc_dflags hsc_env
149 (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env
150 fam_inst_env msg_var
151 static_binds_var
152
153 ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
154 loadDAP $
155 initDPHBuiltins $
156 tryM thing_inside -- Catch exceptions (= errors during desugaring)
157
158 -- Display any errors and warnings
159 -- Note: if -Werror is used, we don't signal an error here.
160 ; msgs <- readIORef msg_var
161
162 ; let final_res | errorsFound dflags msgs = Nothing
163 | otherwise = case either_res of
164 Right res -> Just res
165 Left exn -> pprPanic "initDs" (text (show exn))
166 -- The (Left exn) case happens when the thing_inside throws
167 -- a UserError exception. Then it should have put an error
168 -- message in msg_var, so we just discard the exception
169
170 ; return (msgs, final_res)
171 }
172 where
173 -- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of
174 -- * 'Data.Array.Parallel' iff '-XParallelArrays' specified (see also 'checkLoadDAP').
175 -- * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified.
176 loadDAP thing_inside
177 = do { dapEnv <- loadOneModule dATA_ARRAY_PARALLEL_NAME checkLoadDAP paErr
178 ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (goptM Opt_Vectorise) veErr
179 ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside
180 }
181 where
182 loadOneModule :: ModuleName -- the module to load
183 -> DsM Bool -- under which condition
184 -> MsgDoc -- error message if module not found
185 -> DsM GlobalRdrEnv -- empty if condition 'False'
186 loadOneModule modname check err
187 = do { doLoad <- check
188 ; if not doLoad
189 then return emptyGlobalRdrEnv
190 else do {
191 ; result <- liftIO $ findImportedModule hsc_env modname Nothing
192 ; case result of
193 Found _ mod -> loadModule err mod
194 _ -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err
195 } }
196
197 paErr = ptext (sLit "To use ParallelArrays,") <+> specBackend $$ hint1 $$ hint2
198 veErr = ptext (sLit "To use -fvectorise,") <+> specBackend $$ hint1 $$ hint2
199 specBackend = ptext (sLit "you must specify a DPH backend package")
200 hint1 = ptext (sLit "Look for packages named 'dph-lifted-*' with 'ghc-pkg'")
201 hint2 = ptext (sLit "You may need to install them with 'cabal install dph-examples'")
202
203 initDPHBuiltins thing_inside
204 = do { -- If '-XParallelArrays' given, we populate the builtin table for desugaring those
205 ; doInitBuiltins <- checkLoadDAP
206 ; if doInitBuiltins
207 then dsInitPArrBuiltin thing_inside
208 else thing_inside
209 }
210
211 checkLoadDAP = do { paEnabled <- xoptM Opt_ParallelArrays
212 ; return $ paEnabled &&
213 mod /= gHC_PARR' &&
214 moduleName mod /= dATA_ARRAY_PARALLEL_NAME
215 }
216 -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a
217 -- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top
218 -- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries
219
220 initDsTc :: DsM a -> TcM a
221 initDsTc thing_inside
222 = do { this_mod <- getModule
223 ; tcg_env <- getGblEnv
224 ; msg_var <- getErrsVar
225 ; dflags <- getDynFlags
226 ; static_binds_var <- liftIO $ newIORef []
227 ; let type_env = tcg_type_env tcg_env
228 rdr_env = tcg_rdr_env tcg_env
229 fam_inst_env = tcg_fam_inst_env tcg_env
230 ds_envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
231 msg_var static_binds_var
232 ; setEnvs ds_envs thing_inside
233 }
234
235 initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
236 -- Spin up a TcM context so that we can run the constraint solver
237 -- Returns any error messages generated by the constraint solver
238 -- and (Just res) if no error happened; Nothing if an errror happened
239 --
240 -- Simon says: I'm not very happy about this. We spin up a complete TcM monad
241 -- only to immediately refine it to a TcS monad.
242 -- Better perhaps to make TcS into its own monad, rather than building on TcS
243 -- But that may in turn interact with plugins
244
245 initTcDsForSolver thing_inside
246 = do { (gbl, lcl) <- getEnvs
247 ; hsc_env <- getTopEnv
248
249 ; let DsGblEnv { ds_mod = mod
250 , ds_fam_inst_env = fam_inst_env } = gbl
251
252 DsLclEnv { dsl_loc = loc } = lcl
253
254 ; liftIO $ initTc hsc_env HsSrcFile False mod loc $
255 updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $
256 thing_inside }
257
258 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
259 -> IORef Messages -> IORef [(Fingerprint, (Id, CoreExpr))]
260 -> (DsGblEnv, DsLclEnv)
261 mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var
262 = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
263 if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
264 real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
265 gbl_env = DsGblEnv { ds_mod = mod
266 , ds_fam_inst_env = fam_inst_env
267 , ds_if_env = (if_genv, if_lenv)
268 , ds_unqual = mkPrintUnqualified dflags rdr_env
269 , ds_msgs = msg_var
270 , ds_dph_env = emptyGlobalRdrEnv
271 , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
272 , ds_static_binds = static_binds_var
273 }
274 lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
275 , dsl_loc = real_span
276 , dsl_dicts = emptyBag
277 , dsl_tm_cs = emptyBag
278 }
279 in (gbl_env, lcl_env)
280
281 -- Attempt to load the given module and return its exported entities if successful.
282 --
283 loadModule :: SDoc -> Module -> DsM GlobalRdrEnv
284 loadModule doc mod
285 = do { env <- getGblEnv
286 ; setEnvs (ds_if_env env) $ do
287 { iface <- loadInterface doc mod ImportBySystem
288 ; case iface of
289 Failed err -> pprPanic "DsMonad.loadModule: failed to load" (err $$ doc)
290 Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
291 } }
292 where
293 prov = Just (ImpSpec { is_decl = imp_spec, is_item = ImpAll })
294 imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,
295 is_dloc = wiredInSrcSpan, is_as = name }
296 name = moduleName mod
297
298 {-
299 ************************************************************************
300 * *
301 Operations in the monad
302 * *
303 ************************************************************************
304
305 And all this mysterious stuff is so we can occasionally reach out and
306 grab one or more names. @newLocalDs@ isn't exported---exported
307 functions are defined with it. The difference in name-strings makes
308 it easier to read debugging output.
309 -}
310
311 -- Make a new Id with the same print name, but different type, and new unique
312 newUniqueId :: Id -> Type -> DsM Id
313 newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id)))
314
315 duplicateLocalDs :: Id -> DsM Id
316 duplicateLocalDs old_local
317 = do { uniq <- newUnique
318 ; return (setIdUnique old_local uniq) }
319
320 newPredVarDs :: PredType -> DsM Var
321 newPredVarDs pred
322 = newSysLocalDs pred
323
324 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
325 newSysLocalDs = mkSysLocalM (fsLit "ds")
326 newFailLocalDs = mkSysLocalM (fsLit "fail")
327
328 newSysLocalsDs :: [Type] -> DsM [Id]
329 newSysLocalsDs tys = mapM newSysLocalDs tys
330
331 {-
332 We can also reach out and either set/grab location information from
333 the @SrcSpan@ being carried around.
334 -}
335
336 getGhcModeDs :: DsM GhcMode
337 getGhcModeDs = getDynFlags >>= return . ghcMode
338
339 -- | Get in-scope type constraints (pm check)
340 getDictsDs :: DsM (Bag EvVar)
341 getDictsDs = do { env <- getLclEnv; return (dsl_dicts env) }
342
343 -- | Add in-scope type constraints (pm check)
344 addDictsDs :: Bag EvVar -> DsM a -> DsM a
345 addDictsDs ev_vars
346 = updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) })
347
348 -- | Get in-scope term constraints (pm check)
349 getTmCsDs :: DsM (Bag SimpleEq)
350 getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) }
351
352 -- | Add in-scope term constraints (pm check)
353 addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a
354 addTmCsDs tm_cs
355 = updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) })
356
357 getSrcSpanDs :: DsM SrcSpan
358 getSrcSpanDs = do { env <- getLclEnv
359 ; return (RealSrcSpan (dsl_loc env)) }
360
361 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
362 putSrcSpanDs (UnhelpfulSpan {}) thing_inside
363 = thing_inside
364 putSrcSpanDs (RealSrcSpan real_span) thing_inside
365 = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
366
367 warnDs :: SDoc -> DsM ()
368 warnDs warn = do { env <- getGblEnv
369 ; loc <- getSrcSpanDs
370 ; dflags <- getDynFlags
371 ; let msg = mkWarnMsg dflags loc (ds_unqual env) warn
372 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
373
374 failWithDs :: SDoc -> DsM a
375 failWithDs err
376 = do { env <- getGblEnv
377 ; loc <- getSrcSpanDs
378 ; dflags <- getDynFlags
379 ; let msg = mkErrMsg dflags loc (ds_unqual env) err
380 ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
381 ; failM }
382
383 mkPrintUnqualifiedDs :: DsM PrintUnqualified
384 mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
385
386 instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
387 lookupThing = dsLookupGlobal
388
389 dsLookupGlobal :: Name -> DsM TyThing
390 -- Very like TcEnv.tcLookupGlobal
391 dsLookupGlobal name
392 = do { env <- getGblEnv
393 ; setEnvs (ds_if_env env)
394 (tcIfaceGlobal name) }
395
396 dsLookupGlobalId :: Name -> DsM Id
397 dsLookupGlobalId name
398 = tyThingId <$> dsLookupGlobal name
399
400 -- |Get a name from "Data.Array.Parallel" for the desugarer, from the 'ds_parr_bi' component of the
401 -- global desugerar environment.
402 --
403 dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a
404 dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv
405
406 dsLookupTyCon :: Name -> DsM TyCon
407 dsLookupTyCon name
408 = tyThingTyCon <$> dsLookupGlobal name
409
410 dsLookupDataCon :: Name -> DsM DataCon
411 dsLookupDataCon name
412 = tyThingDataCon <$> dsLookupGlobal name
413
414 -- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'.
415 -- Panic if there isn't one, or if it is defined multiple times.
416 dsLookupDPHRdrEnv :: OccName -> DsM Name
417 dsLookupDPHRdrEnv occ
418 = liftM (fromMaybe (pprPanic nameNotFound (ppr occ)))
419 $ dsLookupDPHRdrEnv_maybe occ
420 where nameNotFound = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':"
421
422 -- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim',
423 -- returning `Nothing` if it's not defined. Panic if it's defined multiple times.
424 dsLookupDPHRdrEnv_maybe :: OccName -> DsM (Maybe Name)
425 dsLookupDPHRdrEnv_maybe occ
426 = do { env <- ds_dph_env <$> getGblEnv
427 ; let gres = lookupGlobalRdrEnv env occ
428 ; case gres of
429 [] -> return $ Nothing
430 [gre] -> return $ Just $ gre_name gre
431 _ -> pprPanic multipleNames (ppr occ)
432 }
433 where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':"
434
435
436 -- Populate 'ds_parr_bi' from 'ds_dph_env'.
437 --
438 dsInitPArrBuiltin :: DsM a -> DsM a
439 dsInitPArrBuiltin thing_inside
440 = do { lengthPVar <- externalVar (fsLit "lengthP")
441 ; replicatePVar <- externalVar (fsLit "replicateP")
442 ; singletonPVar <- externalVar (fsLit "singletonP")
443 ; mapPVar <- externalVar (fsLit "mapP")
444 ; filterPVar <- externalVar (fsLit "filterP")
445 ; zipPVar <- externalVar (fsLit "zipP")
446 ; crossMapPVar <- externalVar (fsLit "crossMapP")
447 ; indexPVar <- externalVar (fsLit "!:")
448 ; emptyPVar <- externalVar (fsLit "emptyP")
449 ; appPVar <- externalVar (fsLit "+:+")
450 -- ; enumFromToPVar <- externalVar (fsLit "enumFromToP")
451 -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP")
452 ; enumFromToPVar <- return arithErr
453 ; enumFromThenToPVar <- return arithErr
454
455 ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin
456 { lengthPVar = lengthPVar
457 , replicatePVar = replicatePVar
458 , singletonPVar = singletonPVar
459 , mapPVar = mapPVar
460 , filterPVar = filterPVar
461 , zipPVar = zipPVar
462 , crossMapPVar = crossMapPVar
463 , indexPVar = indexPVar
464 , emptyPVar = emptyPVar
465 , appPVar = appPVar
466 , enumFromToPVar = enumFromToPVar
467 , enumFromThenToPVar = enumFromThenToPVar
468 } })
469 thing_inside
470 }
471 where
472 externalVar :: FastString -> DsM Var
473 externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
474
475 arithErr = panic "Arithmetic sequences have to wait until we support type classes"
476
477 dsGetFamInstEnvs :: DsM FamInstEnvs
478 -- Gets both the external-package inst-env
479 -- and the home-pkg inst env (includes module being compiled)
480 dsGetFamInstEnvs
481 = do { eps <- getEps; env <- getGblEnv
482 ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
483
484 dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
485 dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
486
487 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
488 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
489
490 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
491 dsExtendMetaEnv menv thing_inside
492 = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
493
494 -- | Gets a reference to the SPT entries created so far.
495 dsGetStaticBindsVar :: DsM (IORef [(Fingerprint, (Id,CoreExpr))])
496 dsGetStaticBindsVar = fmap ds_static_binds getGblEnv
497
498 discardWarningsDs :: DsM a -> DsM a
499 -- Ignore warnings inside the thing inside;
500 -- used to ignore inaccessable cases etc. inside generated code
501 discardWarningsDs thing_inside
502 = do { env <- getGblEnv
503 ; old_msgs <- readTcRef (ds_msgs env)
504
505 ; result <- thing_inside
506
507 -- Revert messages to old_msgs
508 ; writeTcRef (ds_msgs env) old_msgs
509
510 ; return result }