551165a3adc0257da2979339323f578d6c6e1c7f
[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         getDOptsDs, 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 getDOptsDs :: DsM DynFlags
350 getDOptsDs = getDOpts
351
352 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
353 doptDs = doptM
354
355 woptDs :: WarningFlag -> TcRnIf gbl lcl Bool
356 woptDs = woptM
357
358 getGhcModeDs :: DsM GhcMode
359 getGhcModeDs =  getDOptsDs >>= return . ghcMode
360
361 getModuleDs :: DsM Module
362 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
363
364 getSrcSpanDs :: DsM SrcSpan
365 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
366
367 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
368 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
369
370 warnDs :: SDoc -> DsM ()
371 warnDs warn = do { env <- getGblEnv 
372                  ; loc <- getSrcSpanDs
373                  ; let msg = mkWarnMsg loc (ds_unqual env)  warn
374                  ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
375
376 failWithDs :: SDoc -> DsM a
377 failWithDs err 
378   = do  { env <- getGblEnv 
379         ; loc <- getSrcSpanDs
380         ; let msg = mkErrMsg loc (ds_unqual env) err
381         ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
382         ; failM }
383
384 mkPrintUnqualifiedDs :: DsM PrintUnqualified
385 mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
386 \end{code}
387
388 \begin{code}
389 instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
390     lookupThing = dsLookupGlobal
391
392 dsLookupGlobal :: Name -> DsM TyThing
393 -- Very like TcEnv.tcLookupGlobal
394 dsLookupGlobal name 
395   = do  { env <- getGblEnv
396         ; setEnvs (ds_if_env env)
397                   (tcIfaceGlobal name) }
398
399 dsLookupGlobalId :: Name -> DsM Id
400 dsLookupGlobalId name 
401   = tyThingId <$> dsLookupGlobal name
402
403 -- |Get a name from "Data.Array.Parallel" for the desugarer, from the 'ds_parr_bi' component of the
404 -- global desugerar environment.
405 --
406 dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a
407 dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv
408
409 dsLookupTyCon :: Name -> DsM TyCon
410 dsLookupTyCon name
411   = tyThingTyCon <$> dsLookupGlobal name
412
413 dsLookupDataCon :: Name -> DsM DataCon
414 dsLookupDataCon name
415   = tyThingDataCon <$> dsLookupGlobal name
416 \end{code}
417
418 \begin{code}
419
420
421 -- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'.
422 --  Panic if there isn't one, or if it is defined multiple times.
423 dsLookupDPHRdrEnv :: OccName -> DsM Name
424 dsLookupDPHRdrEnv occ
425   = liftM (fromMaybe (pprPanic nameNotFound (ppr occ)))
426   $ dsLookupDPHRdrEnv_maybe occ
427   where nameNotFound  = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':"
428
429 -- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim',
430 --  returning `Nothing` if it's not defined. Panic if it's defined multiple times.
431 dsLookupDPHRdrEnv_maybe :: OccName -> DsM (Maybe Name)
432 dsLookupDPHRdrEnv_maybe occ
433   = do { env <- ds_dph_env <$> getGblEnv
434        ; let gres = lookupGlobalRdrEnv env occ
435        ; case gres of
436            []    -> return $ Nothing
437            [gre] -> return $ Just $ gre_name gre
438            _     -> pprPanic multipleNames (ppr occ)
439        }
440   where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':"
441
442
443 -- Populate 'ds_parr_bi' from 'ds_dph_env'.
444 --
445 dsInitPArrBuiltin :: DsM a -> DsM a
446 dsInitPArrBuiltin thing_inside
447   = do { lengthPVar         <- externalVar (fsLit "lengthP")
448        ; replicatePVar      <- externalVar (fsLit "replicateP")
449        ; singletonPVar      <- externalVar (fsLit "singletonP")
450        ; mapPVar            <- externalVar (fsLit "mapP")
451        ; filterPVar         <- externalVar (fsLit "filterP")
452        ; zipPVar            <- externalVar (fsLit "zipP")
453        ; crossMapPVar       <- externalVar (fsLit "crossMapP")
454        ; indexPVar          <- externalVar (fsLit "!:")
455        ; emptyPVar          <- externalVar (fsLit "emptyP")
456        ; appPVar            <- externalVar (fsLit "+:+")
457        -- ; enumFromToPVar     <- externalVar (fsLit "enumFromToP")
458        -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP")
459        ; enumFromToPVar     <- return arithErr
460        ; enumFromThenToPVar <- return arithErr
461
462        ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin
463                                               { lengthPVar         = lengthPVar
464                                               , replicatePVar      = replicatePVar
465                                               , singletonPVar      = singletonPVar
466                                               , mapPVar            = mapPVar
467                                               , filterPVar         = filterPVar
468                                               , zipPVar            = zipPVar
469                                               , crossMapPVar       = crossMapPVar
470                                               , indexPVar          = indexPVar
471                                               , emptyPVar          = emptyPVar
472                                               , appPVar            = appPVar
473                                               , enumFromToPVar     = enumFromToPVar
474                                               , enumFromThenToPVar = enumFromThenToPVar
475                                               } })
476                    thing_inside
477        }
478   where
479     externalVar :: FastString -> DsM Var
480     externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
481     
482     arithErr = panic "Arithmetic sequences have to wait until we support type classes"
483 \end{code}
484
485 \begin{code}
486 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
487 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
488
489 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
490 dsExtendMetaEnv menv thing_inside
491   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
492 \end{code}