ghc/compiler/deSugar/DsMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[DsMonad]{@DsMonad@: monadery used in desugaring}
   5
   6 \begin{code}
   7 module DsMonad (
   8         DsM, mappM,
   9         initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, foldlDs,
  10
  11         newTyVarsDs,
  12         duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
  13         newFailLocalDs,
  14         getSrcSpanDs, putSrcSpanDs,
  15         getModuleDs,
  16         newUnique,
  17         UniqSupply, newUniqueSupply,
  18         getDOptsDs,
  19         dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
  20
  21         DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
  22
  23         -- Warnings
  24         DsWarning, dsWarn,
  25
  26         -- Data types
  27         DsMatchContext(..),
  28         EquationInfo(..), MatchResult(..), DsWrapper, idWrapper,
  29         CanItFail(..), orFail
  30     ) where
  31
  32 #include "HsVersions.h"
  33
  34 import TcRnMonad
  35 import CoreSyn          ( CoreExpr )
  36 import HsSyn            ( HsExpr, HsMatchContext, Pat )
  37 import TcIface          ( tcIfaceGlobal )
  38 import RdrName          ( GlobalRdrEnv )
  39 import HscTypes         ( TyThing(..), TypeEnv, HscEnv,
  40                           tyThingId, tyThingTyCon, tyThingDataCon, unQualInScope )
  41 import Bag              ( emptyBag, snocBag, Bag )
  42 import DataCon          ( DataCon )
  43 import TyCon            ( TyCon )
  44 import Id               ( mkSysLocal, setIdUnique, Id )
  45 import Module           ( Module )
  46 import Var              ( TyVar, setTyVarUnique )
  47 import Outputable
  48 import SrcLoc           ( noSrcSpan, SrcSpan )
  49 import Type             ( Type )
  50 import UniqSupply       ( UniqSupply, uniqsFromSupply )
  51 import Name             ( Name, nameOccName )
  52 import NameEnv
  53 import OccName          ( occNameFS )
  54 import DynFlags ( DynFlags )
  55 import ErrUtils         ( WarnMsg, mkWarnMsg )
  56 import Bag              ( mapBag )
  57
  58 import DATA_IOREF       ( newIORef, readIORef )
  59
  60 infixr 9 `thenDs`
  61 \end{code}
  62
  63 %************************************************************************
  64 %*                                                                      *
  65                 Data types for the desugarer
  66 %*                                                                      *
  67 %************************************************************************
  68
  69 \begin{code}
  70 data DsMatchContext
  71   = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan
  72   | NoMatchContext
  73   deriving ()
  74
  75 data EquationInfo
  76   = EqnInfo { eqn_wrap :: DsWrapper,    -- Bindings
  77               eqn_pats :: [Pat Id],     -- The patterns for an eqn
  78               eqn_rhs  :: MatchResult } -- What to do after match
  79
  80 type DsWrapper = CoreExpr -> CoreExpr
  81 idWrapper e = e
  82
  83 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
  84 --      \fail. wrap (case vs of { pats -> rhs fail })
  85 -- where vs are not in the domain of wrap
  86
  87
  88 -- A MatchResult is an expression with a hole in it
  89 data MatchResult
  90   = MatchResult
  91         CanItFail       -- Tells whether the failure expression is used
  92         (CoreExpr -> DsM CoreExpr)
  93                         -- Takes a expression to plug in at the
  94                         -- failure point(s). The expression should
  95                         -- be duplicatable!
  96
  97 data CanItFail = CanFail | CantFail
  98
  99 orFail CantFail CantFail = CantFail
 100 orFail _        _        = CanFail
 101 \end{code}
 102
 103
 104 %************************************************************************
 105 %*                                                                      *
 106                 Monad stuff
 107 %*                                                                      *
 108 %************************************************************************
 109
 110 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
 111 a @UniqueSupply@ and some annotations, which
 112 presumably include source-file location information:
 113 \begin{code}
 114 type DsM result = TcRnIf DsGblEnv DsLclEnv result
 115
 116 -- Compatibility functions
 117 fixDs    = fixM
 118 thenDs   = thenM
 119 returnDs = returnM
 120 listDs   = sequenceM
 121 foldlDs  = foldlM
 122 mapAndUnzipDs = mapAndUnzipM
 123
 124
 125 type DsWarning = (SrcSpan, SDoc)
 126         -- Not quite the same as a WarnMsg, we have an SDoc here
 127         -- and we'll do the print_unqual stuff later on to turn it
 128         -- into a Doc.
 129
 130 data DsGblEnv = DsGblEnv {
 131         ds_mod     :: Module,                   -- For SCC profiling
 132         ds_warns   :: IORef (Bag DsWarning),    -- Warning messages
 133         ds_if_env  :: (IfGblEnv, IfLclEnv)      -- Used for looking up global,
 134                                                 -- possibly-imported things
 135     }
 136
 137 data DsLclEnv = DsLclEnv {
 138         ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
 139         ds_loc     :: SrcSpan           -- to put in pattern-matching error msgs
 140      }
 141
 142 -- Inside [| |] brackets, the desugarer looks
 143 -- up variables in the DsMetaEnv
 144 type DsMetaEnv = NameEnv DsMetaVal
 145
 146 data DsMetaVal
 147    = Bound Id           -- Bound by a pattern inside the [| |].
 148                         -- Will be dynamically alpha renamed.
 149                         -- The Id has type THSyntax.Var
 150
 151    | Splice (HsExpr Id) -- These bindings are introduced by
 152                         -- the PendingSplices on a HsBracketOut
 153
 154 -- initDs returns the UniqSupply out the end (not just the result)
 155
 156 initDs  :: HscEnv
 157         -> Module -> GlobalRdrEnv -> TypeEnv
 158         -> DsM a
 159         -> IO (a, Bag WarnMsg)
 160
 161 initDs hsc_env mod rdr_env type_env thing_inside
 162   = do  { warn_var <- newIORef emptyBag
 163         ; let { if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
 164               ; if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
 165               ; gbl_env = DsGblEnv { ds_mod = mod,
 166                                      ds_if_env = (if_genv, if_lenv),
 167                                      ds_warns = warn_var }
 168               ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
 169                                      ds_loc = noSrcSpan } }
 170
 171         ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside
 172
 173         ; warns <- readIORef warn_var
 174         ; return (res, mapBag mk_warn warns)
 175         }
 176    where
 177     print_unqual = unQualInScope rdr_env
 178
 179     mk_warn :: (SrcSpan,SDoc) -> WarnMsg
 180     mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc
 181 \end{code}
 182
 183 %************************************************************************
 184 %*                                                                      *
 185                 Operations in the monad
 186 %*                                                                      *
 187 %************************************************************************
 188
 189 And all this mysterious stuff is so we can occasionally reach out and
 190 grab one or more names.  @newLocalDs@ isn't exported---exported
 191 functions are defined with it.  The difference in name-strings makes
 192 it easier to read debugging output.
 193
 194 \begin{code}
 195 -- Make a new Id with the same print name, but different type, and new unique
 196 newUniqueId :: Name -> Type -> DsM Id
 197 newUniqueId id ty
 198   = newUnique   `thenDs` \ uniq ->
 199     returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
 200
 201 duplicateLocalDs :: Id -> DsM Id
 202 duplicateLocalDs old_local
 203   = newUnique   `thenDs` \ uniq ->
 204     returnDs (setIdUnique old_local uniq)
 205
 206 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 207 newSysLocalDs ty
 208   = newUnique   `thenDs` \ uniq ->
 209     returnDs (mkSysLocal FSLIT("ds") uniq ty)
 210
 211 newSysLocalsDs tys = mappM newSysLocalDs tys
 212
 213 newFailLocalDs ty
 214   = newUnique   `thenDs` \ uniq ->
 215     returnDs (mkSysLocal FSLIT("fail") uniq ty)
 216         -- The UserLocal bit just helps make the code a little clearer
 217 \end{code}
 218
 219 \begin{code}
 220 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 221 newTyVarsDs tyvar_tmpls
 222   = newUniqueSupply     `thenDs` \ uniqs ->
 223     returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
 224 \end{code}
 225
 226 We can also reach out and either set/grab location information from
 227 the @SrcSpan@ being carried around.
 228
 229 \begin{code}
 230 getDOptsDs :: DsM DynFlags
 231 getDOptsDs = getDOpts
 232
 233 getModuleDs :: DsM Module
 234 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
 235
 236 getSrcSpanDs :: DsM SrcSpan
 237 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
 238
 239 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
 240 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
 241
 242 dsWarn :: DsWarning -> DsM ()
 243 dsWarn (loc,warn) = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
 244             where
 245               msg = ptext SLIT("Warning:") <+> warn
 246 \end{code}
 247
 248 \begin{code}
 249 dsLookupGlobal :: Name -> DsM TyThing
 250 -- Very like TcEnv.tcLookupGlobal
 251 dsLookupGlobal name
 252   = do  { env <- getGblEnv
 253         ; setEnvs (ds_if_env env)
 254                   (tcIfaceGlobal name) }
 255
 256 dsLookupGlobalId :: Name -> DsM Id
 257 dsLookupGlobalId name
 258   = dsLookupGlobal name         `thenDs` \ thing ->
 259     returnDs (tyThingId thing)
 260
 261 dsLookupTyCon :: Name -> DsM TyCon
 262 dsLookupTyCon name
 263   = dsLookupGlobal name         `thenDs` \ thing ->
 264     returnDs (tyThingTyCon thing)
 265
 266 dsLookupDataCon :: Name -> DsM DataCon
 267 dsLookupDataCon name
 268   = dsLookupGlobal name         `thenDs` \ thing ->
 269     returnDs (tyThingDataCon thing)
 270 \end{code}
 271
 272 \begin{code}
 273 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
 274 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
 275
 276 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 277 dsExtendMetaEnv menv thing_inside
 278   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
 279 \end{code}
 280
 281