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