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, ifOptM, unsetOptM,
  13         Applicative(..),(<$>),
  14
  15         newLocalName,
  16         duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
  17         newFailLocalDs, newPredVarDs,
  18         getSrcSpanDs, putSrcSpanDs,
  19         getModuleDs,
  20         newUnique,
  21         UniqSupply, newUniqueSupply,
  22         getDOptsDs, getGhcModeDs, doptDs,
  23         dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
  24         dsLookupClass,
  25
  26         DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
  27
  28         dsLoadModule,
  29
  30         -- Warnings
  31         DsWarning, warnDs, failWithDs,
  32
  33         -- Data types
  34         DsMatchContext(..),
  35         EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
  36         CanItFail(..), orFail
  37     ) where
  38
  39 import TcRnMonad
  40 import CoreSyn
  41 import HsSyn
  42 import TcIface
  43 import LoadIface
  44 import RdrName
  45 import HscTypes
  46 import Bag
  47 import DataCon
  48 import TyCon
  49 import Class
  50 import Id
  51 import Module
  52 import Var
  53 import Outputable
  54 import SrcLoc
  55 import Type
  56 import UniqSupply
  57 import Name
  58 import NameEnv
  59 import DynFlags
  60 import ErrUtils
  61 import FastString
  62
  63 import Data.IORef
  64 \end{code}
  65
  66 %************************************************************************
  67 %*                                                                      *
  68                 Data types for the desugarer
  69 %*                                                                      *
  70 %************************************************************************
  71
  72 \begin{code}
  73 data DsMatchContext
  74   = DsMatchContext (HsMatchContext Name) SrcSpan
  75   | NoMatchContext
  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 \end{code}
 287
 288 \begin{code}
 289 instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
 290     lookupThing = dsLookupGlobal
 291
 292 dsLookupGlobal :: Name -> DsM TyThing
 293 -- Very like TcEnv.tcLookupGlobal
 294 dsLookupGlobal name
 295   = do  { env <- getGblEnv
 296         ; setEnvs (ds_if_env env)
 297                   (tcIfaceGlobal name) }
 298
 299 dsLookupGlobalId :: Name -> DsM Id
 300 dsLookupGlobalId name
 301   = tyThingId <$> dsLookupGlobal name
 302
 303 dsLookupTyCon :: Name -> DsM TyCon
 304 dsLookupTyCon name
 305   = tyThingTyCon <$> dsLookupGlobal name
 306
 307 dsLookupDataCon :: Name -> DsM DataCon
 308 dsLookupDataCon name
 309   = tyThingDataCon <$> dsLookupGlobal name
 310
 311 dsLookupClass :: Name -> DsM Class
 312 dsLookupClass name
 313   = tyThingClass <$> dsLookupGlobal name
 314 \end{code}
 315
 316 \begin{code}
 317 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
 318 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
 319
 320 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 321 dsExtendMetaEnv menv thing_inside
 322   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
 323 \end{code}
 324
 325 \begin{code}
 326 dsLoadModule :: SDoc -> Module -> DsM ()
 327 dsLoadModule doc mod
 328   = do { env <- getGblEnv
 329        ; setEnvs (ds_if_env env)
 330                  (loadSysInterface doc mod >> return ())
 331        }
 332 \end{code}
 333