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         getSrcLocDs, putSrcLocDs,
  15         getModuleDs,
  16         newUnique,
  17         UniqSupply, newUniqueSupply,
  18         getDOptsDs,
  19         dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
  20
  21         DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
  22
  23         dsWarn,
  24         DsWarning,
  25         DsMatchContext(..)
  26     ) where
  27
  28 #include "HsVersions.h"
  29
  30 import TcHsSyn          ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr )
  31 import TcRnMonad
  32 import IfaceEnv         ( tcIfaceGlobal )
  33 import HscTypes         ( TyThing(..), TypeEnv, HscEnv,
  34                           IsBootInterface,
  35                           tyThingId, tyThingTyCon, tyThingDataCon  )
  36 import Bag              ( emptyBag, snocBag, Bag )
  37 import DataCon          ( DataCon )
  38 import TyCon            ( TyCon )
  39 import DataCon          ( DataCon )
  40 import Id               ( mkSysLocal, setIdUnique, Id )
  41 import Module           ( Module, ModuleName, ModuleEnv )
  42 import Var              ( TyVar, setTyVarUnique )
  43 import Outputable
  44 import SrcLoc           ( noSrcLoc, SrcLoc )
  45 import Type             ( Type )
  46 import UniqSupply       ( UniqSupply, uniqsFromSupply )
  47 import Name             ( Name, nameOccName )
  48 import NameEnv
  49 import OccName          ( occNameFS )
  50 import CmdLineOpts      ( DynFlags )
  51
  52 import DATA_IOREF       ( newIORef, readIORef )
  53
  54 infixr 9 `thenDs`
  55 \end{code}
  56
  57 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
  58 a @UniqueSupply@ and some annotations, which
  59 presumably include source-file location information:
  60 \begin{code}
  61 type DsM result = TcRnIf DsGblEnv DsLclEnv result
  62
  63 -- Compatibility functions
  64 fixDs    = fixM
  65 thenDs   = thenM
  66 returnDs = returnM
  67 listDs   = sequenceM
  68 foldlDs  = foldlM
  69 mapAndUnzipDs = mapAndUnzipM
  70
  71
  72 type DsWarning = (SrcLoc, SDoc)
  73
  74 data DsGblEnv = DsGblEnv {
  75         ds_mod     :: Module,                   -- For SCC profiling
  76         ds_warns   :: IORef (Bag DsWarning),    -- Warning messages
  77         ds_if_env  :: IfGblEnv                  -- Used for looking up global,
  78                                                 -- possibly-imported things
  79     }
  80
  81 data DsLclEnv = DsLclEnv {
  82         ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
  83         ds_loc     :: SrcLoc            -- to put in pattern-matching error msgs
  84      }
  85
  86 -- Inside [| |] brackets, the desugarer looks
  87 -- up variables in the DsMetaEnv
  88 type DsMetaEnv = NameEnv DsMetaVal
  89
  90 data DsMetaVal
  91    = Bound Id           -- Bound by a pattern inside the [| |].
  92                         -- Will be dynamically alpha renamed.
  93                         -- The Id has type THSyntax.Var
  94
  95    | Splice TypecheckedHsExpr   -- These bindings are introduced by
  96                                 -- the PendingSplices on a HsBracketOut
  97
  98 -- initDs returns the UniqSupply out the end (not just the result)
  99
 100 initDs  :: HscEnv
 101         -> Module -> TypeEnv
 102         -> ModuleEnv (ModuleName,IsBootInterface)
 103         -> DsM a
 104         -> IO (a, Bag DsWarning)
 105
 106 initDs hsc_env mod type_env is_boot thing_inside
 107   = do  { warn_var <- newIORef emptyBag
 108         ; let { if_env = IfGblEnv { if_rec_types = Just (mod, return type_env),
 109                                     if_is_boot = is_boot }
 110               ; gbl_env = DsGblEnv { ds_mod = mod,
 111                                      ds_if_env = if_env,
 112                                      ds_warns = warn_var }
 113               ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
 114                                      ds_loc = noSrcLoc } }
 115
 116         ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside
 117
 118         ; warns <- readIORef warn_var
 119         ; return (res, warns)
 120         }
 121 \end{code}
 122
 123 And all this mysterious stuff is so we can occasionally reach out and
 124 grab one or more names.  @newLocalDs@ isn't exported---exported
 125 functions are defined with it.  The difference in name-strings makes
 126 it easier to read debugging output.
 127
 128 \begin{code}
 129 -- Make a new Id with the same print name, but different type, and new unique
 130 newUniqueId :: Name -> Type -> DsM Id
 131 newUniqueId id ty
 132   = newUnique   `thenDs` \ uniq ->
 133     returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
 134
 135 duplicateLocalDs :: Id -> DsM Id
 136 duplicateLocalDs old_local
 137   = newUnique   `thenDs` \ uniq ->
 138     returnDs (setIdUnique old_local uniq)
 139
 140 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 141 newSysLocalDs ty
 142   = newUnique   `thenDs` \ uniq ->
 143     returnDs (mkSysLocal FSLIT("ds") uniq ty)
 144
 145 newSysLocalsDs tys = mappM newSysLocalDs tys
 146
 147 newFailLocalDs ty
 148   = newUnique   `thenDs` \ uniq ->
 149     returnDs (mkSysLocal FSLIT("fail") uniq ty)
 150         -- The UserLocal bit just helps make the code a little clearer
 151 \end{code}
 152
 153 \begin{code}
 154 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 155 newTyVarsDs tyvar_tmpls
 156   = newUniqueSupply     `thenDs` \ uniqs ->
 157     returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
 158 \end{code}
 159
 160 We can also reach out and either set/grab location information from
 161 the @SrcLoc@ being carried around.
 162
 163 \begin{code}
 164 getDOptsDs :: DsM DynFlags
 165 getDOptsDs = getDOpts
 166
 167 getModuleDs :: DsM Module
 168 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
 169
 170 getSrcLocDs :: DsM SrcLoc
 171 getSrcLocDs = do { env <- getLclEnv; return (ds_loc env) }
 172
 173 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
 174 putSrcLocDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
 175
 176 dsWarn :: DsWarning -> DsM ()
 177 dsWarn (loc,warn) = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
 178             where
 179               msg = ptext SLIT("Warning:") <+> warn
 180 \end{code}
 181
 182 \begin{code}
 183 dsLookupGlobal :: Name -> DsM TyThing
 184 -- Very like TcEnv.tcLookupGlobal
 185 dsLookupGlobal name
 186   = do  { env <- getGblEnv
 187         ; setEnvs (ds_if_env env, ())
 188                   (tcIfaceGlobal name) }
 189
 190 dsLookupGlobalId :: Name -> DsM Id
 191 dsLookupGlobalId name
 192   = dsLookupGlobal name         `thenDs` \ thing ->
 193     returnDs (tyThingId thing)
 194
 195 dsLookupTyCon :: Name -> DsM TyCon
 196 dsLookupTyCon name
 197   = dsLookupGlobal name         `thenDs` \ thing ->
 198     returnDs (tyThingTyCon thing)
 199
 200 dsLookupDataCon :: Name -> DsM DataCon
 201 dsLookupDataCon name
 202   = dsLookupGlobal name         `thenDs` \ thing ->
 203     returnDs (tyThingDataCon thing)
 204 \end{code}
 205
 206 \begin{code}
 207 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
 208 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
 209
 210 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 211 dsExtendMetaEnv menv thing_inside
 212   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
 213 \end{code}
 214
 215
 216 %************************************************************************
 217 %*                                                                      *
 218 \subsection{Type synonym @EquationInfo@ and access functions for its pieces}
 219 %*                                                                      *
 220 %************************************************************************
 221
 222 \begin{code}
 223 data DsMatchContext
 224   = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc
 225   | NoMatchContext
 226   deriving ()
 227 \end{code}