Expose enabled language extensions to TH
[ghc.git] / compiler / deSugar / DsMonad.hs
index 6220a95..befad44 100644 (file)
@@ -11,7 +11,7 @@
 
 module DsMonad (
         DsM, mapM, mapAndUnzipM,
-        initDs, initDsTc, fixDs,
+        initDs, initDsTc, initTcDsForSolver, fixDs,
         foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM,
         Applicative(..),(<$>),
 
@@ -31,6 +31,9 @@ module DsMonad (
 
         DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
 
+        -- Getting and setting EvVars and term constraints in local environment
+        getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,
+
         -- Warnings
         DsWarning, warnDs, failWithDs, discardWarningsDs,
 
@@ -54,6 +57,7 @@ import HscTypes
 import Bag
 import DataCon
 import TyCon
+import PmExpr
 import Id
 import Module
 import Outputable
@@ -66,7 +70,9 @@ import DynFlags
 import ErrUtils
 import FastString
 import Maybes
+import Var (EvVar)
 import GHC.Fingerprint
+import qualified GHC.LanguageExtensions as LangExt
 
 import Data.IORef
 import Control.Monad
@@ -203,7 +209,7 @@ initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
              else thing_inside
            }
 
-    checkLoadDAP = do { paEnabled <- xoptM Opt_ParallelArrays
+    checkLoadDAP = do { paEnabled <- xoptM LangExt.ParallelArrays
                       ; return $ paEnabled &&
                                  mod /= gHC_PARR' &&
                                  moduleName mod /= dATA_ARRAY_PARALLEL_NAME
@@ -227,12 +233,36 @@ initDsTc thing_inside
         ; setEnvs ds_envs thing_inside
         }
 
+initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
+-- Spin up a TcM context so that we can run the constraint solver
+-- Returns any error messages generated by the constraint solver
+-- and (Just res) if no error happened; Nothing if an errror happened
+--
+-- Simon says: I'm not very happy about this.  We spin up a complete TcM monad
+--             only to immediately refine it to a TcS monad.
+-- Better perhaps to make TcS into its own monad, rather than building on TcS
+-- But that may in turn interact with plugins
+
+initTcDsForSolver thing_inside
+  = do { (gbl, lcl) <- getEnvs
+       ; hsc_env    <- getTopEnv
+
+       ; let DsGblEnv { ds_mod = mod
+                      , ds_fam_inst_env = fam_inst_env } = gbl
+
+             DsLclEnv { dsl_loc = loc }                  = lcl
+
+       ; liftIO $ initTc hsc_env HsSrcFile False mod loc $
+         updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $
+         thing_inside }
+
 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
          -> IORef Messages -> IORef [(Fingerprint, (Id, CoreExpr))]
          -> (DsGblEnv, DsLclEnv)
 mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var
   = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
         if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
+        real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
         gbl_env = DsGblEnv { ds_mod     = mod
                            , ds_fam_inst_env = fam_inst_env
                            , ds_if_env  = (if_genv, if_lenv)
@@ -242,8 +272,10 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var
                            , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
                            , ds_static_binds = static_binds_var
                            }
-        lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
-                           , dsl_loc  = noSrcSpan
+        lcl_env = DsLclEnv { dsl_meta  = emptyNameEnv
+                           , dsl_loc   = real_span
+                           , dsl_dicts = emptyBag
+                           , dsl_tm_cs = emptyBag
                            }
     in (gbl_env, lcl_env)
 
@@ -279,7 +311,7 @@ it easier to read debugging output.
 
 -- Make a new Id with the same print name, but different type, and new unique
 newUniqueId :: Id -> Type -> DsM Id
-newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id)))
+newUniqueId id = mkSysLocalOrCoVarM (occNameFS (nameOccName (idName id)))
 
 duplicateLocalDs :: Id -> DsM Id
 duplicateLocalDs old_local
@@ -291,8 +323,8 @@ newPredVarDs pred
  = newSysLocalDs pred
 
 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
-newSysLocalDs  = mkSysLocalM (fsLit "ds")
-newFailLocalDs = mkSysLocalM (fsLit "fail")
+newSysLocalDs  = mkSysLocalOrCoVarM (fsLit "ds")
+newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail")
 
 newSysLocalsDs :: [Type] -> DsM [Id]
 newSysLocalsDs tys = mapM newSysLocalDs tys
@@ -305,11 +337,34 @@ the @SrcSpan@ being carried around.
 getGhcModeDs :: DsM GhcMode
 getGhcModeDs =  getDynFlags >>= return . ghcMode
 
+-- | Get in-scope type constraints (pm check)
+getDictsDs :: DsM (Bag EvVar)
+getDictsDs = do { env <- getLclEnv; return (dsl_dicts env) }
+
+-- | Add in-scope type constraints (pm check)
+addDictsDs :: Bag EvVar -> DsM a -> DsM a
+addDictsDs ev_vars
+  = updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) })
+
+-- | Get in-scope term constraints (pm check)
+getTmCsDs :: DsM (Bag SimpleEq)
+getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) }
+
+-- | Add in-scope term constraints (pm check)
+addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a
+addTmCsDs tm_cs
+  = updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) })
+
 getSrcSpanDs :: DsM SrcSpan
-getSrcSpanDs = do { env <- getLclEnv; return (dsl_loc env) }
+getSrcSpanDs = do { env <- getLclEnv
+                  ; return (RealSrcSpan (dsl_loc env)) }
 
 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
-putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {dsl_loc = new_loc}) thing_inside
+putSrcSpanDs (UnhelpfulSpan {}) thing_inside
+  = thing_inside
+putSrcSpanDs (RealSrcSpan real_span) thing_inside
+  = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
+
 warnDs :: SDoc -> DsM ()
 warnDs warn = do { env <- getGblEnv
                  ; loc <- getSrcSpanDs