Expose enabled language extensions to TH
[ghc.git] / compiler / deSugar / DsMonad.hs
index 7c56199..befad44 100644 (file)
@@ -7,10 +7,11 @@
 -}
 
 {-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan
 
 module DsMonad (
         DsM, mapM, mapAndUnzipM,
-        initDs, initDsTc, fixDs,
+        initDs, initDsTc, initTcDsForSolver, fixDs,
         foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM,
         Applicative(..),(<$>),
 
@@ -30,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,
 
@@ -47,11 +51,13 @@ import TcIface
 import LoadIface
 import Finder
 import PrelNames
+import RnNames
 import RdrName
 import HscTypes
 import Bag
 import DataCon
 import TyCon
+import PmExpr
 import Id
 import Module
 import Outputable
@@ -64,10 +70,12 @@ 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
-import GHC.Fingerprint
 
 {-
 ************************************************************************
@@ -115,17 +123,11 @@ orFail _        _        = CanFail
 {-
 ************************************************************************
 *                                                                      *
-                Monad stuff
+                Monad functions
 *                                                                      *
 ************************************************************************
-
-Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
-a @UniqueSupply@ and some annotations, which
-presumably include source-file location information:
 -}
 
-type DsM result = TcRnIf DsGblEnv DsLclEnv result
-
 -- Compatibility functions
 fixDs :: (a -> DsM a) -> DsM a
 fixDs    = fixM
@@ -135,62 +137,6 @@ type DsWarning = (SrcSpan, SDoc)
         -- and we'll do the print_unqual stuff later on to turn it
         -- into a Doc.
 
--- If '-XParallelArrays' is given, the desugarer populates this table with the corresponding
--- variables found in 'Data.Array.Parallel'.
---
-data PArrBuiltin
-        = PArrBuiltin
-        { lengthPVar         :: Var     -- ^ lengthP
-        , replicatePVar      :: Var     -- ^ replicateP
-        , singletonPVar      :: Var     -- ^ singletonP
-        , mapPVar            :: Var     -- ^ mapP
-        , filterPVar         :: Var     -- ^ filterP
-        , zipPVar            :: Var     -- ^ zipP
-        , crossMapPVar       :: Var     -- ^ crossMapP
-        , indexPVar          :: Var     -- ^ (!:)
-        , emptyPVar          :: Var     -- ^ emptyP
-        , appPVar            :: Var     -- ^ (+:+)
-        , enumFromToPVar     :: Var     -- ^ enumFromToP
-        , enumFromThenToPVar :: Var     -- ^ enumFromThenToP
-        }
-
-data DsGblEnv
-        = DsGblEnv
-        { ds_mod          :: Module             -- For SCC profiling
-        , ds_fam_inst_env :: FamInstEnv         -- Like tcg_fam_inst_env
-        , ds_unqual  :: PrintUnqualified
-        , ds_msgs    :: IORef Messages          -- Warning messages
-        , ds_if_env  :: (IfGblEnv, IfLclEnv)    -- Used for looking up global,
-                                                -- possibly-imported things
-        , ds_dph_env :: GlobalRdrEnv            -- exported entities of 'Data.Array.Parallel.Prim'
-                                                -- iff '-fvectorise' flag was given as well as
-                                                -- exported entities of 'Data.Array.Parallel' iff
-                                                -- '-XParallelArrays' was given; otherwise, empty
-        , ds_parr_bi :: PArrBuiltin             -- desugarar names for '-XParallelArrays'
-        , ds_static_binds :: IORef [(Fingerprint, (Id,CoreExpr))]
-          -- ^ Bindings resulted from floating static forms
-        }
-
-instance ContainsModule DsGblEnv where
-    extractModule = ds_mod
-
-data DsLclEnv = DsLclEnv {
-        ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
-        ds_loc     :: SrcSpan           -- to put in pattern-matching error msgs
-     }
-
--- Inside [| |] brackets, the desugarer looks
--- up variables in the DsMetaEnv
-type DsMetaEnv = NameEnv DsMetaVal
-
-data DsMetaVal
-   = Bound Id           -- Bound by a pattern inside the [| |].
-                        -- Will be dynamically alpha renamed.
-                        -- The Id has type THSyntax.Var
-
-   | Splice (HsExpr Id) -- These bindings are introduced by
-                        -- the PendingSplices on a HsBracketOut
-
 initDs :: HscEnv
        -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
        -> DsM a
@@ -263,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
@@ -287,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)
@@ -302,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 { ds_meta = emptyNameEnv
-                           , ds_loc  = noSrcSpan
+        lcl_env = DsLclEnv { dsl_meta  = emptyNameEnv
+                           , dsl_loc   = real_span
+                           , dsl_dicts = emptyBag
+                           , dsl_tm_cs = emptyBag
                            }
     in (gbl_env, lcl_env)
 
@@ -319,7 +291,7 @@ loadModule doc mod
            Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
        } }
   where
-    prov     = Imported [ImpSpec { is_decl = imp_spec, is_item = ImpAll }]
+    prov     = Just (ImpSpec { is_decl = imp_spec, is_item = ImpAll })
     imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,
                              is_dloc = wiredInSrcSpan, is_as = name }
     name = moduleName mod
@@ -339,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
@@ -351,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
@@ -365,11 +337,33 @@ 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 (ds_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 {ds_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
@@ -489,14 +483,14 @@ dsGetFamInstEnvs
        ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
 
 dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
-dsGetMetaEnv = do { env <- getLclEnv; return (ds_meta env) }
+dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
 
 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
-dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
+dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
 
 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 dsExtendMetaEnv menv thing_inside
-  = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
+  = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
 
 -- | Gets a reference to the SPT entries created so far.
 dsGetStaticBindsVar :: DsM (IORef [(Fingerprint, (Id,CoreExpr))])