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