Remove getDOptsDs; use getDynFlags instead
[ghc.git] / compiler / deSugar / DsMonad.lhs
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 \begin{code}
9 module DsMonad (
10         DsM, mapM, mapAndUnzipM,
11         initDs, initDsTc, fixDs,
12         foldlM, foldrM, ifDOptM, unsetDOptM, unsetWOptM,
13         Applicative(..),(<$>),
14
15         newLocalName,
16         duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
17         newFailLocalDs, newPredVarDs,
18         getSrcSpanDs, putSrcSpanDs,
19         getModuleDs,
20         mkPrintUnqualifiedDs,
21         newUnique, 
22         UniqSupply, newUniqueSupply,
23         getGhcModeDs, doptDs, woptDs,
24         dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
25         
26         PArrBuiltin(..), 
27         dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe,
28         dsInitPArrBuiltin,
29
30         DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
31
32         -- Warnings
33         DsWarning, warnDs, failWithDs,
34
35         -- Data types
36         DsMatchContext(..),
37         EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
38         CanItFail(..), orFail
39     ) where
40
41 import TcRnMonad
42 import CoreSyn
43 import HsSyn
44 import TcIface
45 import LoadIface
46 import Finder
47 import PrelNames
48 import Avail
49 import RdrName
50 import HscTypes
51 import Bag
52 import DataCon
53 import TyCon
54 import Id
55 import Module
56 import Outputable
57 import SrcLoc
58 import Type
59 import UniqSupply
60 import Name
61 import NameEnv
62 import DynFlags
63 import ErrUtils
64 import FastString
65 import Maybes
66
67 import Data.IORef
68 import Control.Monad
69 \end{code}
70
71 %************************************************************************
72 %*                                                                      *
73                 Data types for the desugarer
74 %*                                                                      *
75 %************************************************************************
76
77 \begin{code}
78 data DsMatchContext
79   = DsMatchContext (HsMatchContext Name) SrcSpan
80   deriving ()
81
82 data EquationInfo
83   = EqnInfo { eqn_pats :: [Pat Id],     -- The patterns for an eqn
84               eqn_rhs  :: MatchResult } -- What to do after match
85
86 instance Outputable EquationInfo where
87     ppr (EqnInfo pats _) = ppr pats
88
89 type DsWrapper = CoreExpr -> CoreExpr
90 idDsWrapper :: DsWrapper
91 idDsWrapper e = e
92
93 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
94 --      \fail. wrap (case vs of { pats -> rhs fail })
95 -- where vs are not bound by wrap
96
97
98 -- A MatchResult is an expression with a hole in it
99 data MatchResult
100   = MatchResult
101         CanItFail       -- Tells whether the failure expression is used
102         (CoreExpr -> DsM CoreExpr)
103                         -- Takes a expression to plug in at the
104                         -- failure point(s). The expression should
105                         -- be duplicatable!
106
107 data CanItFail = CanFail | CantFail
108
109 orFail :: CanItFail -> CanItFail -> CanItFail
110 orFail CantFail CantFail = CantFail
111 orFail _        _        = CanFail
112 \end{code}
113
114
115 %************************************************************************
116 %*                                                                      *
117                 Monad stuff
118 %*                                                                      *
119 %************************************************************************
120
121 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
122 a @UniqueSupply@ and some annotations, which
123 presumably include source-file location information:
124
125 \begin{code}
126 type DsM result = TcRnIf DsGblEnv DsLclEnv result
127
128 -- Compatibility functions
129 fixDs :: (a -> DsM a) -> DsM a
130 fixDs    = fixM
131
132 type DsWarning = (SrcSpan, SDoc)
133         -- Not quite the same as a WarnMsg, we have an SDoc here 
134         -- and we'll do the print_unqual stuff later on to turn it
135         -- into a Doc.
136
137 -- If '-XParallelArrays' is given, the desugarer populates this table with the corresponding
138 -- variables found in 'Data.Array.Parallel'.
139 --
140 data PArrBuiltin
141         = PArrBuiltin
142         { lengthPVar         :: Var     -- ^ lengthP
143         , replicatePVar      :: Var     -- ^ replicateP
144         , singletonPVar      :: Var     -- ^ singletonP
145         , mapPVar            :: Var     -- ^ mapP
146         , filterPVar         :: Var     -- ^ filterP
147         , zipPVar            :: Var     -- ^ zipP
148         , crossMapPVar       :: Var     -- ^ crossMapP
149         , indexPVar          :: Var     -- ^ (!:)
150         , emptyPVar          :: Var     -- ^ emptyP
151         , appPVar            :: Var     -- ^ (+:+)
152         , enumFromToPVar     :: Var     -- ^ enumFromToP
153         , enumFromThenToPVar :: Var     -- ^ enumFromThenToP
154         }
155
156 data DsGblEnv 
157         = DsGblEnv
158         { ds_mod     :: Module                  -- For SCC profiling
159         , ds_unqual  :: PrintUnqualified
160         , ds_msgs    :: IORef Messages          -- Warning messages
161         , ds_if_env  :: (IfGblEnv, IfLclEnv)    -- Used for looking up global, 
162                                                 -- possibly-imported things
163         , ds_dph_env :: GlobalRdrEnv            -- exported entities of 'Data.Array.Parallel.Prim'
164                                                 -- iff '-fvectorise' flag was given as well as
165                                                 -- exported entities of 'Data.Array.Parallel' iff
166                                                 -- '-XParallelArrays' was given; otherwise, empty
167         , ds_parr_bi :: PArrBuiltin             -- desugarar names for '-XParallelArrays'
168         }
169
170 data DsLclEnv = DsLclEnv {
171         ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
172         ds_loc     :: SrcSpan           -- to put in pattern-matching error msgs
173      }
174
175 -- Inside [| |] brackets, the desugarer looks 
176 -- up variables in the DsMetaEnv
177 type DsMetaEnv = NameEnv DsMetaVal
178
179 data DsMetaVal
180    = Bound Id           -- Bound by a pattern inside the [| |]. 
181                         -- Will be dynamically alpha renamed.
182                         -- The Id has type THSyntax.Var
183
184    | Splice (HsExpr Id) -- These bindings are introduced by
185                         -- the PendingSplices on a HsBracketOut
186
187 initDs :: HscEnv
188        -> Module -> GlobalRdrEnv -> TypeEnv
189        -> DsM a
190        -> IO (Messages, Maybe a)
191 -- Print errors and warnings, if any arise
192
193 initDs hsc_env mod rdr_env type_env thing_inside
194   = do  { msg_var <- newIORef (emptyBag, emptyBag)
195         ; let dflags                   = hsc_dflags hsc_env
196               (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env msg_var
197
198         ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
199                           loadDAP $
200                             initDPHBuiltins $
201                               tryM thing_inside     -- Catch exceptions (= errors during desugaring)
202
203         -- Display any errors and warnings 
204         -- Note: if -Werror is used, we don't signal an error here.
205         ; msgs <- readIORef msg_var
206
207         ; let final_res | errorsFound dflags msgs = Nothing
208                         | otherwise = case either_res of
209                                         Right res -> Just res
210                                         Left exn  -> pprPanic "initDs" (text (show exn))
211                 -- The (Left exn) case happens when the thing_inside throws
212                 -- a UserError exception.  Then it should have put an error
213                 -- message in msg_var, so we just discard the exception
214
215         ; return (msgs, final_res) 
216         }
217   where
218     -- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of
219     --   * 'Data.Array.Parallel'      iff '-XParallalArrays' specified (see also 'checkLoadDAP').
220     --   * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified.
221     loadDAP thing_inside
222       = do { dapEnv  <- loadOneModule dATA_ARRAY_PARALLEL_NAME      checkLoadDAP          paErr
223            ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (doptM Opt_Vectorise) veErr
224            ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside
225            }
226       where
227         loadOneModule :: ModuleName           -- the module to load
228                       -> DsM Bool             -- under which condition
229                       -> MsgDoc              -- error message if module not found
230                       -> DsM GlobalRdrEnv     -- empty if condition 'False'
231         loadOneModule modname check err
232           = do { doLoad <- check
233                ; if not doLoad 
234                  then return emptyGlobalRdrEnv
235                  else do {
236                ; result <- liftIO $ findImportedModule hsc_env modname Nothing
237                ; case result of
238                    Found _ mod -> loadModule err mod
239                    _           -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err
240                } }
241
242         paErr       = ptext (sLit "To use -XParallelArrays,") <+> specBackend $$ hint1 $$ hint2
243         veErr       = ptext (sLit "To use -fvectorise,") <+> specBackend $$ hint1 $$ hint2
244         specBackend = ptext (sLit "you must specify a DPH backend package")
245         hint1       = ptext (sLit "Look for packages named 'dph-lifted-*' with 'ghc-pkg'")
246         hint2       = ptext (sLit "You may need to install them with 'cabal install dph-examples'")
247
248     initDPHBuiltins thing_inside
249       = do {   -- If '-XParallelArrays' given, we populate the builtin table for desugaring those
250            ; doInitBuiltins <- checkLoadDAP
251            ; if doInitBuiltins
252              then dsInitPArrBuiltin thing_inside
253              else thing_inside
254            }
255
256     checkLoadDAP = do { paEnabled <- xoptM Opt_ParallelArrays
257                       ; return $ paEnabled &&
258                                  mod /= gHC_PARR' && 
259                                  moduleName mod /= dATA_ARRAY_PARALLEL_NAME
260                       }
261                       -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a
262                       -- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top
263                       -- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries
264
265 initDsTc :: DsM a -> TcM a
266 initDsTc thing_inside
267   = do  { this_mod <- getModule
268         ; tcg_env  <- getGblEnv
269         ; msg_var  <- getErrsVar
270         ; dflags   <- getDOpts
271         ; let type_env = tcg_type_env tcg_env
272               rdr_env  = tcg_rdr_env tcg_env
273               ds_envs  = mkDsEnvs dflags this_mod rdr_env type_env msg_var
274         ; setEnvs ds_envs thing_inside
275         }
276
277 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> (DsGblEnv, DsLclEnv)
278 mkDsEnvs dflags mod rdr_env type_env msg_var
279   = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
280         if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
281         gbl_env = DsGblEnv { ds_mod     = mod
282                            , ds_if_env  = (if_genv, if_lenv)
283                            , ds_unqual  = mkPrintUnqualified dflags rdr_env
284                            , ds_msgs    = msg_var
285                            , ds_dph_env = emptyGlobalRdrEnv
286                            , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
287                            }
288         lcl_env = DsLclEnv { ds_meta = emptyNameEnv
289                            , ds_loc  = noSrcSpan
290                            }
291     in (gbl_env, lcl_env)
292
293 -- Attempt to load the given module and return its exported entities if successful.
294 --
295 loadModule :: SDoc -> Module -> DsM GlobalRdrEnv
296 loadModule doc mod
297   = do { env    <- getGblEnv
298        ; setEnvs (ds_if_env env) $ do
299        { iface <- loadInterface doc mod ImportBySystem
300        ; case iface of
301            Failed err      -> pprPanic "DsMonad.loadModule: failed to load" (err $$ doc)
302            Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
303        } }
304   where
305     prov     = Imported [ImpSpec { is_decl = imp_spec, is_item = ImpAll }]
306     imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,
307                              is_dloc = wiredInSrcSpan, is_as = name }
308     name = moduleName mod
309 \end{code}
310
311
312 %************************************************************************
313 %*                                                                      *
314                 Operations in the monad
315 %*                                                                      *
316 %************************************************************************
317
318 And all this mysterious stuff is so we can occasionally reach out and
319 grab one or more names.  @newLocalDs@ isn't exported---exported
320 functions are defined with it.  The difference in name-strings makes
321 it easier to read debugging output.
322
323 \begin{code}
324 -- Make a new Id with the same print name, but different type, and new unique
325 newUniqueId :: Id -> Type -> DsM Id
326 newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id)))
327
328 duplicateLocalDs :: Id -> DsM Id
329 duplicateLocalDs old_local 
330   = do  { uniq <- newUnique
331         ; return (setIdUnique old_local uniq) }
332
333 newPredVarDs :: PredType -> DsM Var
334 newPredVarDs pred
335  = newSysLocalDs pred
336  
337 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
338 newSysLocalDs  = mkSysLocalM (fsLit "ds")
339 newFailLocalDs = mkSysLocalM (fsLit "fail")
340
341 newSysLocalsDs :: [Type] -> DsM [Id]
342 newSysLocalsDs tys = mapM newSysLocalDs tys
343 \end{code}
344
345 We can also reach out and either set/grab location information from
346 the @SrcSpan@ being carried around.
347
348 \begin{code}
349 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
350 doptDs = doptM
351
352 woptDs :: WarningFlag -> TcRnIf gbl lcl Bool
353 woptDs = woptM
354
355 getGhcModeDs :: DsM GhcMode
356 getGhcModeDs =  getDynFlags >>= return . ghcMode
357
358 getModuleDs :: DsM Module
359 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
360
361 getSrcSpanDs :: DsM SrcSpan
362 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
363
364 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
365 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
366
367 warnDs :: SDoc -> DsM ()
368 warnDs warn = do { env <- getGblEnv 
369                  ; loc <- getSrcSpanDs
370                  ; let msg = mkWarnMsg loc (ds_unqual env)  warn
371                  ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
372
373 failWithDs :: SDoc -> DsM a
374 failWithDs err 
375   = do  { env <- getGblEnv 
376         ; loc <- getSrcSpanDs
377         ; let msg = mkErrMsg loc (ds_unqual env) err
378         ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
379         ; failM }
380
381 mkPrintUnqualifiedDs :: DsM PrintUnqualified
382 mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
383 \end{code}
384
385 \begin{code}
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 \end{code}
414
415 \begin{code}
416
417
418 -- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'.
419 --  Panic if there isn't one, or if it is defined multiple times.
420 dsLookupDPHRdrEnv :: OccName -> DsM Name
421 dsLookupDPHRdrEnv occ
422   = liftM (fromMaybe (pprPanic nameNotFound (ppr occ)))
423   $ dsLookupDPHRdrEnv_maybe occ
424   where nameNotFound  = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':"
425
426 -- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim',
427 --  returning `Nothing` if it's not defined. Panic if it's defined multiple times.
428 dsLookupDPHRdrEnv_maybe :: OccName -> DsM (Maybe Name)
429 dsLookupDPHRdrEnv_maybe occ
430   = do { env <- ds_dph_env <$> getGblEnv
431        ; let gres = lookupGlobalRdrEnv env occ
432        ; case gres of
433            []    -> return $ Nothing
434            [gre] -> return $ Just $ gre_name gre
435            _     -> pprPanic multipleNames (ppr occ)
436        }
437   where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':"
438
439
440 -- Populate 'ds_parr_bi' from 'ds_dph_env'.
441 --
442 dsInitPArrBuiltin :: DsM a -> DsM a
443 dsInitPArrBuiltin thing_inside
444   = do { lengthPVar         <- externalVar (fsLit "lengthP")
445        ; replicatePVar      <- externalVar (fsLit "replicateP")
446        ; singletonPVar      <- externalVar (fsLit "singletonP")
447        ; mapPVar            <- externalVar (fsLit "mapP")
448        ; filterPVar         <- externalVar (fsLit "filterP")
449        ; zipPVar            <- externalVar (fsLit "zipP")
450        ; crossMapPVar       <- externalVar (fsLit "crossMapP")
451        ; indexPVar          <- externalVar (fsLit "!:")
452        ; emptyPVar          <- externalVar (fsLit "emptyP")
453        ; appPVar            <- externalVar (fsLit "+:+")
454        -- ; enumFromToPVar     <- externalVar (fsLit "enumFromToP")
455        -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP")
456        ; enumFromToPVar     <- return arithErr
457        ; enumFromThenToPVar <- return arithErr
458
459        ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin
460                                               { lengthPVar         = lengthPVar
461                                               , replicatePVar      = replicatePVar
462                                               , singletonPVar      = singletonPVar
463                                               , mapPVar            = mapPVar
464                                               , filterPVar         = filterPVar
465                                               , zipPVar            = zipPVar
466                                               , crossMapPVar       = crossMapPVar
467                                               , indexPVar          = indexPVar
468                                               , emptyPVar          = emptyPVar
469                                               , appPVar            = appPVar
470                                               , enumFromToPVar     = enumFromToPVar
471                                               , enumFromThenToPVar = enumFromThenToPVar
472                                               } })
473                    thing_inside
474        }
475   where
476     externalVar :: FastString -> DsM Var
477     externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
478     
479     arithErr = panic "Arithmetic sequences have to wait until we support type classes"
480 \end{code}
481
482 \begin{code}
483 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
484 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
485
486 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
487 dsExtendMetaEnv menv thing_inside
488   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
489 \end{code}