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, unsetOptM,
  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,
  24         dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon,
  25         dsLookupClass,
  26
  27         DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
  28
  29         dsLoadModule,
  30
  31         -- Warnings
  32         DsWarning, warnDs, failWithDs,
  33
  34         -- Data types
  35         DsMatchContext(..),
  36         EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
  37         CanItFail(..), orFail
  38     ) where
  39
  40 import TcRnMonad
  41 import CoreSyn
  42 import HsSyn
  43 import TcIface
  44 import LoadIface
  45 import RdrName
  46 import HscTypes
  47 import Bag
  48 import DataCon
  49 import TyCon
  50 import Class
  51 import Id
  52 import Module
  53 import Var
  54 import Outputable
  55 import SrcLoc
  56 import Type
  57 import UniqSupply
  58 import Name
  59 import NameEnv
  60 import DynFlags
  61 import ErrUtils
  62 import FastString
  63
  64 import Data.IORef
  65 \end{code}
  66
  67 %************************************************************************
  68 %*                                                                      *
  69                 Data types for the desugarer
  70 %*                                                                      *
  71 %************************************************************************
  72
  73 \begin{code}
  74 data DsMatchContext
  75   = DsMatchContext (HsMatchContext Name) SrcSpan
  76   deriving ()
  77
  78 data EquationInfo
  79   = EqnInfo { eqn_pats :: [Pat Id],     -- The patterns for an eqn
  80               eqn_rhs  :: MatchResult } -- What to do after match
  81
  82 instance Outputable EquationInfo where
  83     ppr (EqnInfo pats _) = ppr pats
  84
  85 type DsWrapper = CoreExpr -> CoreExpr
  86 idDsWrapper :: DsWrapper
  87 idDsWrapper e = e
  88
  89 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
  90 --      \fail. wrap (case vs of { pats -> rhs fail })
  91 -- where vs are not bound by wrap
  92
  93
  94 -- A MatchResult is an expression with a hole in it
  95 data MatchResult
  96   = MatchResult
  97         CanItFail       -- Tells whether the failure expression is used
  98         (CoreExpr -> DsM CoreExpr)
  99                         -- Takes a expression to plug in at the
 100                         -- failure point(s). The expression should
 101                         -- be duplicatable!
 102
 103 data CanItFail = CanFail | CantFail
 104
 105 orFail :: CanItFail -> CanItFail -> CanItFail
 106 orFail CantFail CantFail = CantFail
 107 orFail _        _        = CanFail
 108 \end{code}
 109
 110
 111 %************************************************************************
 112 %*                                                                      *
 113                 Monad stuff
 114 %*                                                                      *
 115 %************************************************************************
 116
 117 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
 118 a @UniqueSupply@ and some annotations, which
 119 presumably include source-file location information:
 120 \begin{code}
 121 type DsM result = TcRnIf DsGblEnv DsLclEnv result
 122
 123 -- Compatibility functions
 124 fixDs :: (a -> DsM a) -> DsM a
 125 fixDs    = fixM
 126
 127 type DsWarning = (SrcSpan, SDoc)
 128         -- Not quite the same as a WarnMsg, we have an SDoc here
 129         -- and we'll do the print_unqual stuff later on to turn it
 130         -- into a Doc.
 131
 132 data DsGblEnv = DsGblEnv {
 133         ds_mod     :: Module,                   -- For SCC profiling
 134         ds_unqual  :: PrintUnqualified,
 135         ds_msgs    :: IORef Messages,           -- Warning messages
 136         ds_if_env  :: (IfGblEnv, IfLclEnv)      -- Used for looking up global,
 137                                                 -- possibly-imported things
 138     }
 139
 140 data DsLclEnv = DsLclEnv {
 141         ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
 142         ds_loc     :: SrcSpan           -- to put in pattern-matching error msgs
 143      }
 144
 145 -- Inside [| |] brackets, the desugarer looks
 146 -- up variables in the DsMetaEnv
 147 type DsMetaEnv = NameEnv DsMetaVal
 148
 149 data DsMetaVal
 150    = Bound Id           -- Bound by a pattern inside the [| |].
 151                         -- Will be dynamically alpha renamed.
 152                         -- The Id has type THSyntax.Var
 153
 154    | Splice (HsExpr Id) -- These bindings are introduced by
 155                         -- the PendingSplices on a HsBracketOut
 156
 157 initDs  :: HscEnv
 158         -> Module -> GlobalRdrEnv -> TypeEnv
 159         -> DsM a
 160         -> IO (Messages, Maybe a)
 161 -- Print errors and warnings, if any arise
 162
 163 initDs hsc_env mod rdr_env type_env thing_inside
 164   = do  { msg_var <- newIORef (emptyBag, emptyBag)
 165         ; let dflags = hsc_dflags hsc_env
 166         ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs dflags mod rdr_env type_env msg_var
 167
 168         ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
 169                         tryM thing_inside       -- Catch exceptions (= errors during desugaring)
 170
 171         -- Display any errors and warnings
 172         -- Note: if -Werror is used, we don't signal an error here.
 173         ; msgs <- readIORef msg_var
 174
 175         ; let final_res | errorsFound dflags msgs = Nothing
 176                         | otherwise = case either_res of
 177                                         Right res -> Just res
 178                                         Left exn -> pprPanic "initDs" (text (show exn))
 179                 -- The (Left exn) case happens when the thing_inside throws
 180                 -- a UserError exception.  Then it should have put an error
 181                 -- message in msg_var, so we just discard the exception
 182
 183         ; return (msgs, final_res) }
 184
 185 initDsTc :: DsM a -> TcM a
 186 initDsTc thing_inside
 187   = do  { this_mod <- getModule
 188         ; tcg_env  <- getGblEnv
 189         ; msg_var  <- getErrsVar
 190         ; dflags   <- getDOpts
 191         ; let type_env = tcg_type_env tcg_env
 192               rdr_env  = tcg_rdr_env tcg_env
 193         ; ds_envs <- liftIO $ mkDsEnvs dflags this_mod rdr_env type_env msg_var
 194         ; setEnvs ds_envs thing_inside }
 195
 196 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
 197 mkDsEnvs dflags mod rdr_env type_env msg_var
 198   = do -- TODO: unnecessarily monadic
 199        let     if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
 200                if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
 201                gbl_env = DsGblEnv { ds_mod = mod,
 202                                     ds_if_env = (if_genv, if_lenv),
 203                                     ds_unqual = mkPrintUnqualified dflags rdr_env,
 204                                     ds_msgs = msg_var}
 205                lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
 206                                     ds_loc = noSrcSpan }
 207
 208        return (gbl_env, lcl_env)
 209 \end{code}
 210
 211 %************************************************************************
 212 %*                                                                      *
 213                 Operations in the monad
 214 %*                                                                      *
 215 %************************************************************************
 216
 217 And all this mysterious stuff is so we can occasionally reach out and
 218 grab one or more names.  @newLocalDs@ isn't exported---exported
 219 functions are defined with it.  The difference in name-strings makes
 220 it easier to read debugging output.
 221
 222 \begin{code}
 223 -- Make a new Id with the same print name, but different type, and new unique
 224 newUniqueId :: Id -> Type -> DsM Id
 225 newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id)))
 226
 227 duplicateLocalDs :: Id -> DsM Id
 228 duplicateLocalDs old_local
 229   = do  { uniq <- newUnique
 230         ; return (setIdUnique old_local uniq) }
 231
 232 newPredVarDs :: PredType -> DsM Var
 233 newPredVarDs pred
 234  | isEqPred pred
 235  = do { uniq <- newUnique;
 236       ; let name = mkSystemName uniq (mkOccNameFS tcName (fsLit "co_pv"))
 237             kind = mkPredTy pred
 238       ; return (mkCoVar name kind) }
 239  | otherwise
 240  = newSysLocalDs (mkPredTy pred)
 241
 242 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 243 newSysLocalDs  = mkSysLocalM (fsLit "ds")
 244 newFailLocalDs = mkSysLocalM (fsLit "fail")
 245
 246 newSysLocalsDs :: [Type] -> DsM [Id]
 247 newSysLocalsDs tys = mapM newSysLocalDs tys
 248 \end{code}
 249
 250 We can also reach out and either set/grab location information from
 251 the @SrcSpan@ being carried around.
 252
 253 \begin{code}
 254 getDOptsDs :: DsM DynFlags
 255 getDOptsDs = getDOpts
 256
 257 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
 258 doptDs = doptM
 259
 260 getGhcModeDs :: DsM GhcMode
 261 getGhcModeDs =  getDOptsDs >>= return . ghcMode
 262
 263 getModuleDs :: DsM Module
 264 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
 265
 266 getSrcSpanDs :: DsM SrcSpan
 267 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
 268
 269 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
 270 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
 271
 272 warnDs :: SDoc -> DsM ()
 273 warnDs warn = do { env <- getGblEnv
 274                  ; loc <- getSrcSpanDs
 275                  ; let msg = mkWarnMsg loc (ds_unqual env)
 276                                       (ptext (sLit "Warning:") <+> warn)
 277                  ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
 278
 279 failWithDs :: SDoc -> DsM a
 280 failWithDs err
 281   = do  { env <- getGblEnv
 282         ; loc <- getSrcSpanDs
 283         ; let msg = mkErrMsg loc (ds_unqual env) err
 284         ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
 285         ; failM }
 286
 287 mkPrintUnqualifiedDs :: DsM PrintUnqualified
 288 mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
 289 \end{code}
 290
 291 \begin{code}
 292 instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
 293     lookupThing = dsLookupGlobal
 294
 295 dsLookupGlobal :: Name -> DsM TyThing
 296 -- Very like TcEnv.tcLookupGlobal
 297 dsLookupGlobal name
 298   = do  { env <- getGblEnv
 299         ; setEnvs (ds_if_env env)
 300                   (tcIfaceGlobal name) }
 301
 302 dsLookupGlobalId :: Name -> DsM Id
 303 dsLookupGlobalId name
 304   = tyThingId <$> dsLookupGlobal name
 305
 306 -- Looking up a global DPH 'Id' is like 'dsLookupGlobalId', but the package, in which the looked
 307 -- up name is located, varies with the active DPH backend.
 308 --
 309 dsLookupDPHId :: (PackageId -> Name) -> DsM Id
 310 dsLookupDPHId nameInPkg
 311   = do { dflags <- getDOpts
 312        ; case dphPackageMaybe dflags of
 313            Just pkg -> tyThingId <$> dsLookupGlobal (nameInPkg pkg)
 314            Nothing  -> failWithDs $ ptext err
 315        }
 316   where
 317     err = sLit "To use -XParallelArrays select a DPH backend with -fdph-par or -fdph-seq"
 318
 319 dsLookupTyCon :: Name -> DsM TyCon
 320 dsLookupTyCon name
 321   = tyThingTyCon <$> dsLookupGlobal name
 322
 323 dsLookupDataCon :: Name -> DsM DataCon
 324 dsLookupDataCon name
 325   = tyThingDataCon <$> dsLookupGlobal name
 326
 327 dsLookupClass :: Name -> DsM Class
 328 dsLookupClass name
 329   = tyThingClass <$> dsLookupGlobal name
 330 \end{code}
 331
 332 \begin{code}
 333 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
 334 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
 335
 336 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 337 dsExtendMetaEnv menv thing_inside
 338   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
 339 \end{code}
 340
 341 \begin{code}
 342 dsLoadModule :: SDoc -> Module -> DsM ()
 343 dsLoadModule doc mod
 344   = do { env <- getGblEnv
 345        ; setEnvs (ds_if_env env)
 346                  (loadSysInterface doc mod >> return ())
 347        }
 348 \end{code}
 349