Commit c1e25536 authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

Expose enabled language extensions to TH

This exposes `template-haskell` functions for querying the language
extensions which are enabled when compiling a module,

- an `isExtEnabled` function to check whether an extension is enabled
- an `extsEnabled` function to obtain a full list of enabled extensions

To avoid code duplication this adds a `GHC.LanguageExtensions` module to
`ghc-boot` and moves `DynFlags.ExtensionFlag` into it. A happy
consequence of this is that the ungainly `DynFlags` lost around 500
lines. Moreover, flags corresponding to language extensions are now
clearly distinguished from other flags due to the `LangExt.*` prefix.

Updates haddock submodule.

This fixes #10820.

Test Plan: validate

Reviewers: austin, spinda, hvr, goldfire, alanz

Reviewed By: goldfire

Subscribers: mpickering, RyanGlScott, hvr, simonpj, thomie

Differential Revision: https://phabricator.haskell.org/D1200

GHC Trac Issues: #10820
parent 28638dfe
...@@ -74,6 +74,7 @@ import DynFlags ...@@ -74,6 +74,7 @@ import DynFlags
import Outputable import Outputable
import FastString import FastString
import ListSetOps import ListSetOps
import qualified GHC.LanguageExtensions as LangExt
import Data.Maybe ( maybeToList ) import Data.Maybe ( maybeToList )
...@@ -622,7 +623,7 @@ dataConSrcToImplBang ...@@ -622,7 +623,7 @@ dataConSrcToImplBang
dataConSrcToImplBang dflags fam_envs arg_ty dataConSrcToImplBang dflags fam_envs arg_ty
(HsSrcBang ann unpk NoSrcStrict) (HsSrcBang ann unpk NoSrcStrict)
| xopt Opt_StrictData dflags -- StrictData => strict field | xopt LangExt.StrictData dflags -- StrictData => strict field
= dataConSrcToImplBang dflags fam_envs arg_ty = dataConSrcToImplBang dflags fam_envs arg_ty
(HsSrcBang ann unpk SrcStrict) (HsSrcBang ann unpk SrcStrict)
| otherwise -- no StrictData => lazy field | otherwise -- no StrictData => lazy field
...@@ -771,13 +772,13 @@ isUnpackableType dflags fam_envs ty ...@@ -771,13 +772,13 @@ isUnpackableType dflags fam_envs ty
-- We'd get a black hole if we used dataConImplBangs -- We'd get a black hole if we used dataConImplBangs
attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict) attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)
= xopt Opt_StrictData dflags = xopt LangExt.StrictData dflags
attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict) attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)
= True = True
attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict) attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict)
= True -- Be conservative = True -- Be conservative
attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict) attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict)
= xopt Opt_StrictData dflags -- Be conservative = xopt LangExt.StrictData dflags -- Be conservative
attempt_unpack _ = False attempt_unpack _ = False
{- {-
......
...@@ -66,6 +66,7 @@ import DynFlags ...@@ -66,6 +66,7 @@ import DynFlags
import FastString import FastString
import Util import Util
import MonadUtils import MonadUtils
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad import Control.Monad
{-********************************************************************** {-**********************************************************************
...@@ -118,7 +119,7 @@ dsHsBind dflags ...@@ -118,7 +119,7 @@ dsHsBind dflags
; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
| otherwise = var | otherwise = var
; let core_bind@(id,_) = makeCorePair dflags var' False 0 core_expr ; let core_bind@(id,_) = makeCorePair dflags var' False 0 core_expr
force_var = if xopt Opt_Strict dflags force_var = if xopt LangExt.Strict dflags
then [id] then [id]
else [] else []
; return (force_var, [core_bind]) } ; return (force_var, [core_bind]) }
...@@ -131,7 +132,7 @@ dsHsBind dflags ...@@ -131,7 +132,7 @@ dsHsBind dflags
; rhs <- dsHsWrapper co_fn (mkLams args body') ; rhs <- dsHsWrapper co_fn (mkLams args body')
; let core_binds@(id,_) = makeCorePair dflags fun False 0 rhs ; let core_binds@(id,_) = makeCorePair dflags fun False 0 rhs
force_var = force_var =
if xopt Opt_Strict dflags if xopt LangExt.Strict dflags
&& matchGroupArity matches == 0 -- no need to force lambdas && matchGroupArity matches == 0 -- no need to force lambdas
then [id] then [id]
else [] else []
...@@ -163,7 +164,7 @@ dsHsBind dflags ...@@ -163,7 +164,7 @@ dsHsBind dflags
, abs_ev_binds = ev_binds, abs_binds = binds }) , abs_ev_binds = ev_binds, abs_binds = binds })
| ABE { abe_wrap = wrap, abe_poly = global | ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = prags } <- export , abe_mono = local, abe_prags = prags } <- export
, not (xopt Opt_Strict dflags) -- handle strict binds , not (xopt LangExt.Strict dflags) -- handle strict binds
, not (anyBag (isBangedPatBind . unLoc) binds) -- in the next case , not (anyBag (isBangedPatBind . unLoc) binds) -- in the next case
= -- push type constraints deeper for pattern match check = -- push type constraints deeper for pattern match check
addDictsDs (toTcTypeBag (listToBag dicts)) $ addDictsDs (toTcTypeBag (listToBag dicts)) $
......
...@@ -72,6 +72,7 @@ import FastString ...@@ -72,6 +72,7 @@ import FastString
import Maybes import Maybes
import Var (EvVar) import Var (EvVar)
import GHC.Fingerprint import GHC.Fingerprint
import qualified GHC.LanguageExtensions as LangExt
import Data.IORef import Data.IORef
import Control.Monad import Control.Monad
...@@ -208,7 +209,7 @@ initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside ...@@ -208,7 +209,7 @@ initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
else thing_inside else thing_inside
} }
checkLoadDAP = do { paEnabled <- xoptM Opt_ParallelArrays checkLoadDAP = do { paEnabled <- xoptM LangExt.ParallelArrays
; return $ paEnabled && ; return $ paEnabled &&
mod /= gHC_PARR' && mod /= gHC_PARR' &&
moduleName mod /= dATA_ARRAY_PARALLEL_NAME moduleName mod /= dATA_ARRAY_PARALLEL_NAME
......
...@@ -72,6 +72,7 @@ import SrcLoc ...@@ -72,6 +72,7 @@ import SrcLoc
import Util import Util
import DynFlags import DynFlags
import FastString import FastString
import qualified GHC.LanguageExtensions as LangExt
import TcEvidence import TcEvidence
...@@ -885,7 +886,7 @@ getUnBangedLPat dflags (L l (ParPat p)) ...@@ -885,7 +886,7 @@ getUnBangedLPat dflags (L l (ParPat p))
getUnBangedLPat _ (L _ (BangPat p)) getUnBangedLPat _ (L _ (BangPat p))
= (True,p) = (True,p)
getUnBangedLPat dflags (L _ (LazyPat p)) getUnBangedLPat dflags (L _ (LazyPat p))
| xopt Opt_Strict dflags | xopt LangExt.Strict dflags
= (False,p) = (False,p)
getUnBangedLPat dflags p getUnBangedLPat dflags p
= (xopt Opt_Strict dflags,p) = (xopt LangExt.Strict dflags,p)
...@@ -43,8 +43,9 @@ import BasicTypes ...@@ -43,8 +43,9 @@ import BasicTypes
import DynFlags import DynFlags
import Util import Util
import FastString import FastString
import Control.Monad import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.Int import Data.Int
#if __GLASGOW_HASKELL__ < 709 #if __GLASGOW_HASKELL__ < 709
import Data.Traversable (traverse) import Data.Traversable (traverse)
...@@ -184,7 +185,7 @@ warnAboutOverflowedLiterals dflags lit ...@@ -184,7 +185,7 @@ warnAboutOverflowedLiterals dflags lit
maxB = toInteger (maxBound :: a) maxB = toInteger (maxBound :: a)
sug | minB == -i -- Note [Suggest NegativeLiterals] sug | minB == -i -- Note [Suggest NegativeLiterals]
, i > 0 , i > 0
, not (xopt Opt_NegativeLiterals dflags) , not (xopt LangExt.NegativeLiterals dflags)
= ptext (sLit "If you are trying to write a large negative literal, use NegativeLiterals") = ptext (sLit "If you are trying to write a large negative literal, use NegativeLiterals")
| otherwise = Outputable.empty | otherwise = Outputable.empty
......
...@@ -62,6 +62,7 @@ import MonadUtils ...@@ -62,6 +62,7 @@ import MonadUtils
import Platform import Platform
import TcRnTypes import TcRnTypes
import Hooks import Hooks
import qualified GHC.LanguageExtensions as LangExt
import Exception import Exception
import System.Directory import System.Directory
...@@ -135,8 +136,8 @@ compileOne' m_tc_result mHscMessage ...@@ -135,8 +136,8 @@ compileOne' m_tc_result mHscMessage
location = ms_location summary location = ms_location summary
input_fnpp = ms_hspp_file summary input_fnpp = ms_hspp_file summary
mod_graph = hsc_mod_graph hsc_env0 mod_graph = hsc_mod_graph hsc_env0
needsTH = any (xopt Opt_TemplateHaskell . ms_hspp_opts) mod_graph needsTH = any (xopt LangExt.TemplateHaskell . ms_hspp_opts) mod_graph
needsQQ = any (xopt Opt_QuasiQuotes . ms_hspp_opts) mod_graph needsQQ = any (xopt LangExt.QuasiQuotes . ms_hspp_opts) mod_graph
needsLinker = needsTH || needsQQ needsLinker = needsTH || needsQQ
isDynWay = any (== WayDyn) (ways dflags0) isDynWay = any (== WayDyn) (ways dflags0)
isProfWay = any (== WayProf) (ways dflags0) isProfWay = any (== WayProf) (ways dflags0)
...@@ -231,8 +232,8 @@ compileOne' m_tc_result mHscMessage ...@@ -231,8 +232,8 @@ compileOne' m_tc_result mHscMessage
location = ms_location summary location = ms_location summary
input_fn = expectJust "compile:hs" (ml_hs_file location) input_fn = expectJust "compile:hs" (ml_hs_file location)
mod_graph = hsc_mod_graph hsc_env0 mod_graph = hsc_mod_graph hsc_env0
needsTH = any (xopt Opt_TemplateHaskell . ms_hspp_opts) mod_graph needsTH = any (xopt LangExt.TemplateHaskell . ms_hspp_opts) mod_graph
needsQQ = any (xopt Opt_QuasiQuotes . ms_hspp_opts) mod_graph needsQQ = any (xopt LangExt.QuasiQuotes . ms_hspp_opts) mod_graph
needsLinker = needsTH || needsQQ needsLinker = needsTH || needsQQ
isDynWay = any (== WayDyn) (ways dflags0) isDynWay = any (== WayDyn) (ways dflags0)
isProfWay = any (== WayProf) (ways dflags0) isProfWay = any (== WayProf) (ways dflags0)
...@@ -841,7 +842,7 @@ runPhase (RealPhase (Cpp sf)) input_fn dflags0 ...@@ -841,7 +842,7 @@ runPhase (RealPhase (Cpp sf)) input_fn dflags0
setDynFlags dflags1 setDynFlags dflags1
liftIO $ checkProcessArgsResult dflags1 unhandled_flags liftIO $ checkProcessArgsResult dflags1 unhandled_flags
if not (xopt Opt_Cpp dflags1) then do if not (xopt LangExt.Cpp dflags1) then do
-- we have to be careful to emit warnings only once. -- we have to be careful to emit warnings only once.
unless (gopt Opt_Pp dflags1) $ unless (gopt Opt_Pp dflags1) $
liftIO $ handleFlagWarnings dflags1 warns liftIO $ handleFlagWarnings dflags1 warns
......
This diff is collapsed.
...@@ -341,6 +341,7 @@ import FastString ...@@ -341,6 +341,7 @@ import FastString
import qualified Parser import qualified Parser
import Lexer import Lexer
import ApiAnnotation import ApiAnnotation
import qualified GHC.LanguageExtensions as LangExt
import System.Directory ( doesFileExist ) import System.Directory ( doesFileExist )
import Data.Maybe import Data.Maybe
...@@ -1047,7 +1048,7 @@ getModuleGraph = liftM hsc_mod_graph getSession ...@@ -1047,7 +1048,7 @@ getModuleGraph = liftM hsc_mod_graph getSession
-- have Template Haskell enabled whether it is actually needed or not. -- have Template Haskell enabled whether it is actually needed or not.
needsTemplateHaskell :: ModuleGraph -> Bool needsTemplateHaskell :: ModuleGraph -> Bool
needsTemplateHaskell ms = needsTemplateHaskell ms =
any (xopt Opt_TemplateHaskell . ms_hspp_opts) ms any (xopt LangExt.TemplateHaskell . ms_hspp_opts) ms
-- | Return @True@ <==> module is loaded. -- | Return @True@ <==> module is loaded.
isLoaded :: GhcMonad m => ModuleName -> m Bool isLoaded :: GhcMonad m => ModuleName -> m Bool
......
...@@ -54,6 +54,7 @@ import StringBuffer ...@@ -54,6 +54,7 @@ import StringBuffer
import SysTools import SysTools
import UniqFM import UniqFM
import Util import Util
import qualified GHC.LanguageExtensions as LangExt
import Data.Either ( rights, partitionEithers ) import Data.Either ( rights, partitionEithers )
import qualified Data.Map as Map import qualified Data.Map as Map
...@@ -1986,7 +1987,7 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) ...@@ -1986,7 +1987,7 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
| Just (Unlit _) <- mb_phase = True | Just (Unlit _) <- mb_phase = True
| Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
-- note: local_opts is only required if there's no Unlit phase -- note: local_opts is only required if there's no Unlit phase
| xopt Opt_Cpp dflags' = True | xopt LangExt.Cpp dflags' = True
| gopt Opt_Pp dflags' = True | gopt Opt_Pp dflags' = True
| otherwise = False | otherwise = False
......
...@@ -38,6 +38,7 @@ import Bag ( emptyBag, listToBag, unitBag ) ...@@ -38,6 +38,7 @@ import Bag ( emptyBag, listToBag, unitBag )
import MonadUtils import MonadUtils
import Exception import Exception
import BasicTypes import BasicTypes
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad import Control.Monad
import System.IO import System.IO
...@@ -83,7 +84,7 @@ getImports dflags buf filename source_filename = do ...@@ -83,7 +84,7 @@ getImports dflags buf filename source_filename = do
ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
ord_idecls ord_idecls
implicit_prelude = xopt Opt_ImplicitPrelude dflags implicit_prelude = xopt LangExt.ImplicitPrelude dflags
implicit_imports = mkPrelImports (unLoc mod) main_loc implicit_imports = mkPrelImports (unLoc mod) main_loc
implicit_prelude imps implicit_prelude imps
convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i) convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
......
...@@ -87,6 +87,9 @@ import Data.List ...@@ -87,6 +87,9 @@ import Data.List
import Data.Maybe import Data.Maybe
import Data.Word import Data.Word
-- ghc-boot
import qualified GHC.LanguageExtensions as LangExt
-- bytestring -- bytestring
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
...@@ -1127,7 +1130,7 @@ varid span buf len = ...@@ -1127,7 +1130,7 @@ varid span buf len =
return $ L span keyword return $ L span keyword
Just (ITstatic, _) -> do Just (ITstatic, _) -> do
flags <- getDynFlags flags <- getDynFlags
if xopt Opt_StaticPointers flags if xopt LangExt.StaticPointers flags
then return $ L span ITstatic then return $ L span ITstatic
else return $ L span $ ITvarid fs else return $ L span $ ITvarid fs
Just (keyword, 0) -> do Just (keyword, 0) -> do
...@@ -2117,39 +2120,39 @@ mkPState flags buf loc = ...@@ -2117,39 +2120,39 @@ mkPState flags buf loc =
annotations_comments = [] annotations_comments = []
} }
where where
bitmap = FfiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags bitmap = FfiBit `setBitIf` xopt LangExt.ForeignFunctionInterface flags
.|. InterruptibleFfiBit `setBitIf` xopt Opt_InterruptibleFFI flags .|. InterruptibleFfiBit `setBitIf` xopt LangExt.InterruptibleFFI flags
.|. CApiFfiBit `setBitIf` xopt Opt_CApiFFI flags .|. CApiFfiBit `setBitIf` xopt LangExt.CApiFFI flags
.|. ParrBit `setBitIf` xopt Opt_ParallelArrays flags .|. ParrBit `setBitIf` xopt LangExt.ParallelArrays flags
.|. ArrowsBit `setBitIf` xopt Opt_Arrows flags .|. ArrowsBit `setBitIf` xopt LangExt.Arrows flags
.|. ThBit `setBitIf` xopt Opt_TemplateHaskell flags .|. ThBit `setBitIf` xopt LangExt.TemplateHaskell flags
.|. ThQuotesBit `setBitIf` xopt Opt_TemplateHaskellQuotes flags .|. ThQuotesBit `setBitIf` xopt LangExt.TemplateHaskellQuotes flags
.|. QqBit `setBitIf` xopt Opt_QuasiQuotes flags .|. QqBit `setBitIf` xopt LangExt.QuasiQuotes flags
.|. IpBit `setBitIf` xopt Opt_ImplicitParams flags .|. IpBit `setBitIf` xopt LangExt.ImplicitParams flags
.|. OverloadedLabelsBit `setBitIf` xopt Opt_OverloadedLabels flags .|. OverloadedLabelsBit `setBitIf` xopt LangExt.OverloadedLabels flags
.|. ExplicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags .|. ExplicitForallBit `setBitIf` xopt LangExt.ExplicitForAll flags
.|. BangPatBit `setBitIf` xopt Opt_BangPatterns flags .|. BangPatBit `setBitIf` xopt LangExt.BangPatterns flags
.|. HaddockBit `setBitIf` gopt Opt_Haddock flags .|. HaddockBit `setBitIf` gopt Opt_Haddock flags
.|. MagicHashBit `setBitIf` xopt Opt_MagicHash flags .|. MagicHashBit `setBitIf` xopt LangExt.MagicHash flags
.|. RecursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags .|. RecursiveDoBit `setBitIf` xopt LangExt.RecursiveDo flags
.|. UnicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags .|. UnicodeSyntaxBit `setBitIf` xopt LangExt.UnicodeSyntax flags
.|. UnboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags .|. UnboxedTuplesBit `setBitIf` xopt LangExt.UnboxedTuples flags
.|. DatatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags .|. DatatypeContextsBit `setBitIf` xopt LangExt.DatatypeContexts flags
.|. TransformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags .|. TransformComprehensionsBit `setBitIf` xopt LangExt.TransformListComp flags
.|. TransformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags .|. TransformComprehensionsBit `setBitIf` xopt LangExt.MonadComprehensions flags
.|. RawTokenStreamBit `setBitIf` gopt Opt_KeepRawTokenStream flags .|. RawTokenStreamBit `setBitIf` gopt Opt_KeepRawTokenStream flags
.|. HpcBit `setBitIf` gopt Opt_Hpc flags .|. HpcBit `setBitIf` gopt Opt_Hpc flags
.|. AlternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags .|. AlternativeLayoutRuleBit `setBitIf` xopt LangExt.AlternativeLayoutRule flags
.|. RelaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags .|. RelaxedLayoutBit `setBitIf` xopt LangExt.RelaxedLayout flags
.|. SccProfilingOnBit `setBitIf` gopt Opt_SccProfilingOn flags .|. SccProfilingOnBit `setBitIf` gopt Opt_SccProfilingOn flags
.|. NondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags .|. NondecreasingIndentationBit `setBitIf` xopt LangExt.NondecreasingIndentation flags
.|. SafeHaskellBit `setBitIf` safeImportsOn flags .|. SafeHaskellBit `setBitIf` safeImportsOn flags
.|. TraditionalRecordSyntaxBit `setBitIf` xopt Opt_TraditionalRecordSyntax flags .|. TraditionalRecordSyntaxBit `setBitIf` xopt LangExt.TraditionalRecordSyntax flags
.|. ExplicitNamespacesBit `setBitIf` xopt Opt_ExplicitNamespaces flags .|. ExplicitNamespacesBit `setBitIf` xopt LangExt.ExplicitNamespaces flags
.|. LambdaCaseBit `setBitIf` xopt Opt_LambdaCase flags .|. LambdaCaseBit `setBitIf` xopt LangExt.LambdaCase flags
.|. BinaryLiteralsBit `setBitIf` xopt Opt_BinaryLiterals flags .|. BinaryLiteralsBit `setBitIf` xopt LangExt.BinaryLiterals flags
.|. NegativeLiteralsBit `setBitIf` xopt Opt_NegativeLiterals flags .|. NegativeLiteralsBit `setBitIf` xopt LangExt.NegativeLiterals flags
.|. PatternSynonymsBit `setBitIf` xopt Opt_PatternSynonyms flags .|. PatternSynonymsBit `setBitIf` xopt LangExt.PatternSynonyms flags
-- --
setBitIf :: ExtBits -> Bool -> ExtsBitmap setBitIf :: ExtBits -> Bool -> ExtsBitmap
b `setBitIf` cond | cond = xbit b b `setBitIf` cond | cond = xbit b
...@@ -2238,7 +2241,7 @@ srcParseErr dflags buf len ...@@ -2238,7 +2241,7 @@ srcParseErr dflags buf len
(text "Perhaps you need a 'let' in a 'do' block?" (text "Perhaps you need a 'let' in a 'do' block?"
$$ text "e.g. 'let x = 5' instead of 'x = 5'") $$ text "e.g. 'let x = 5' instead of 'x = 5'")
where token = lexemeToString (offsetBytes (-len) buf) len where token = lexemeToString (offsetBytes (-len) buf) len
th_enabled = xopt Opt_TemplateHaskell dflags th_enabled = xopt LangExt.TemplateHaskell dflags
-- Report a parse failure, giving the span of the previous token as -- Report a parse failure, giving the span of the previous token as
-- the location of the error. This is the entry point for errors -- the location of the error. This is the entry point for errors
...@@ -2309,7 +2312,7 @@ alternativeLayoutRuleToken t ...@@ -2309,7 +2312,7 @@ alternativeLayoutRuleToken t
justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
setJustClosedExplicitLetBlock False setJustClosedExplicitLetBlock False
dflags <- getDynFlags dflags <- getDynFlags
let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags let transitional = xopt LangExt.AlternativeLayoutRuleTransitional dflags
thisLoc = getLoc t thisLoc = getLoc t
thisCol = srcSpanStartCol thisLoc thisCol = srcSpanStartCol thisLoc
newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc
......
...@@ -83,6 +83,7 @@ import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilD ...@@ -83,6 +83,7 @@ import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilD
import Util ( looksLikePackageName ) import Util ( looksLikePackageName )
import Prelude import Prelude
import qualified GHC.LanguageExtensions as LangExt
} }
{- Last updated: 18 Nov 2015 {- Last updated: 18 Nov 2015
...@@ -3315,14 +3316,14 @@ fileSrcSpan = do ...@@ -3315,14 +3316,14 @@ fileSrcSpan = do
-- Hint about the MultiWayIf extension -- Hint about the MultiWayIf extension
hintMultiWayIf :: SrcSpan -> P () hintMultiWayIf :: SrcSpan -> P ()
hintMultiWayIf span = do hintMultiWayIf span = do
mwiEnabled <- liftM ((Opt_MultiWayIf `xopt`) . dflags) getPState mwiEnabled <- liftM ((LangExt.MultiWayIf `xopt`) . dflags) getPState
unless mwiEnabled $ parseErrorSDoc span $ unless mwiEnabled $ parseErrorSDoc span $
text "Multi-way if-expressions need MultiWayIf turned on" text "Multi-way if-expressions need MultiWayIf turned on"
-- Hint about if usage for beginners -- Hint about if usage for beginners
hintIf :: SrcSpan -> String -> P (LHsExpr RdrName) hintIf :: SrcSpan -> String -> P (LHsExpr RdrName)
hintIf span msg = do hintIf span msg = do
mwiEnabled <- liftM ((Opt_MultiWayIf `xopt`) . dflags) getPState mwiEnabled <- liftM ((LangExt.MultiWayIf `xopt`) . dflags) getPState
if mwiEnabled if mwiEnabled
then parseErrorSDoc span $ text $ "parse error in if statement" then parseErrorSDoc span $ text $ "parse error in if statement"
else parseErrorSDoc span $ text $ "parse error in if statement: "++msg else parseErrorSDoc span $ text $ "parse error in if statement: "++msg
...@@ -3339,7 +3340,7 @@ hintExplicitForall span = do ...@@ -3339,7 +3340,7 @@ hintExplicitForall span = do
] ]
namedWildCardsEnabled :: P Bool namedWildCardsEnabled :: P Bool
namedWildCardsEnabled = liftM ((Opt_NamedWildCards `xopt`) . dflags) getPState namedWildCardsEnabled = liftM ((LangExt.NamedWildCards `xopt`) . dflags) getPState
{- {-
%************************************************************************ %************************************************************************
......
...@@ -92,6 +92,7 @@ import Maybes ...@@ -92,6 +92,7 @@ import Maybes
import Util import Util
import ApiAnnotation import ApiAnnotation
import Data.List import Data.List
import qualified GHC.LanguageExtensions as LangExt
#if __GLASGOW_HASKELL__ < 709 #if __GLASGOW_HASKELL__ < 709
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
...@@ -812,7 +813,7 @@ checkAPat msg loc e0 = do ...@@ -812,7 +813,7 @@ checkAPat msg loc e0 = do
-- n+k patterns -- n+k patterns
OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _ OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _
(L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}}))) (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
| xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR) | xopt LangExt.NPlusKPatterns dynflags && (plus == plus_RDR)
-> return (mkNPlusKPat (L nloc n) (L lloc lit)) -> return (mkNPlusKPat (L nloc n) (L lloc lit))
OpApp l op _fix r -> do l <- checkLPat msg l OpApp l op _fix r -> do l <- checkLPat msg l
...@@ -966,7 +967,7 @@ checkDoAndIfThenElse :: LHsExpr RdrName ...@@ -966,7 +967,7 @@ checkDoAndIfThenElse :: LHsExpr RdrName
checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
| semiThen || semiElse | semiThen || semiElse
= do pState <- getPState = do pState <- getPState
unless (xopt Opt_DoAndIfThenElse (dflags pState)) $ do unless (xopt LangExt.DoAndIfThenElse (dflags pState)) $ do
parseErrorSDoc (combineLocs guardExpr elseExpr) parseErrorSDoc (combineLocs guardExpr elseExpr)
(text "Unexpected semi-colons in conditional:" (text "Unexpected semi-colons in conditional:"
$$ nest 4 expr $$ nest 4 expr
...@@ -1086,7 +1087,7 @@ splitTildeApps (t : rest) = t : concatMap go rest ...@@ -1086,7 +1087,7 @@ splitTildeApps (t : rest) = t : concatMap go rest
checkMonadComp :: P (HsStmtContext Name) checkMonadComp :: P (HsStmtContext Name)
checkMonadComp = do checkMonadComp = do
pState <- getPState pState <- getPState
return $ if xopt Opt_MonadComprehensions (dflags pState) return $ if xopt LangExt.MonadComprehensions (dflags pState)
then MonadComp then MonadComp
else ListComp else ListComp
......
...@@ -48,9 +48,11 @@ import Bag ...@@ -48,9 +48,11 @@ import Bag
import Util import Util
import Outputable import Outputable
import FastString import FastString
import Data.List ( partition, sort )
import Maybes ( orElse ) import Maybes ( orElse )
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad import Control.Monad
import Data.List ( partition, sort )
#if __GLASGOW_HASKELL__ < 709 #if __GLASGOW_HASKELL__ < 709
import Data.Traversable ( traverse ) import Data.Traversable ( traverse )
#endif #endif
...@@ -476,7 +478,7 @@ rnBind sig_fn bind@(FunBind { fun_id = name ...@@ -476,7 +478,7 @@ rnBind sig_fn bind@(FunBind { fun_id = name
= do { let plain_name = unLoc name = do { let plain_name = unLoc name
; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
-- bindSigTyVars tests for Opt_ScopedTyVars -- bindSigTyVars tests for LangExt.ScopedTyVars
rnMatchGroup (FunRhs plain_name) rnMatchGroup (FunRhs plain_name)
rnLExpr matches rnLExpr matches
; let is_infix = isInfixFunBind bind ; let is_infix = isInfixFunBind bind
...@@ -623,7 +625,7 @@ rnPatSynBind _sig_fn bind@(PSB { psb_id = L _ name ...@@ -623,7 +625,7 @@ rnPatSynBind _sig_fn bind@(PSB { psb_id = L _ name
, psb_def = pat , psb_def = pat
, psb_dir = dir }) , psb_dir = dir })
-- invariant: no free vars here when it's a FunBind -- invariant: no free vars here when it's a FunBind
= do { pattern_synonym_ok <- xoptM Opt_PatternSynonyms = do { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms
; unless pattern_synonym_ok (addErr patternSynonymErr) ; unless pattern_synonym_ok (addErr patternSynonymErr)
; ((pat', details'), fvs1) <- rnPat PatSyn pat $ \pat' -> do ; ((pat', details'), fvs1) <- rnPat PatSyn pat $ \pat' -> do
...@@ -781,7 +783,7 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs ...@@ -781,7 +783,7 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs
-- Rename the bindings RHSs. Again there's an issue about whether the -- Rename the bindings RHSs. Again there's an issue about whether the
-- type variables from the class/instance head are in scope. -- type variables from the class/instance head are in scope.
-- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables
; scoped_tvs <- xoptM Opt_ScopedTypeVariables ; scoped_tvs <- xoptM LangExt.ScopedTypeVariables
; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $ ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $
do { binds_w_dus <- mapBagM (rnLBind (mkSigTvFn other_sigs')) binds' do { binds_w_dus <- mapBagM (rnLBind (mkSigTvFn other_sigs')) binds'
; let bind_fvs = foldrBag (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2) ; let bind_fvs = foldrBag (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)
...@@ -881,7 +883,7 @@ renameSig ctxt sig@(TypeSig vs ty) ...@@ -881,7 +883,7 @@ renameSig ctxt sig@(TypeSig vs ty)
; return (TypeSig new_vs new_ty, fvs) } ; return (TypeSig new_vs new_ty, fvs) }
renameSig ctxt sig@(ClassOpSig is_deflt vs ty) renameSig ctxt sig@(ClassOpSig is_deflt vs ty)
= do { defaultSigs_on <- xoptM Opt_DefaultSignatures = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures
; when (is_deflt && not defaultSigs_on) $ ; when (is_deflt && not defaultSigs_on) $
addErr (defaultSigErr sig) addErr (defaultSigErr sig)
; new_v <- mapM (lookupSigOccRn ctxt sig) vs ; new_v <- mapM (lookupSigOccRn ctxt sig) vs
...@@ -1017,7 +1019,7 @@ rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name ...@@ -1017,7 +1019,7 @@ rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name
-> MatchGroup RdrName (Located (body RdrName)) -> MatchGroup RdrName (Located (body RdrName))
-> RnM (MatchGroup Name (Located (body Name)), FreeVars) -> RnM (MatchGroup Name (Located (body Name)), FreeVars)
rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin }) rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })
= do { empty_case_ok <- xoptM Opt_EmptyCase = do { empty_case_ok <- xoptM LangExt.EmptyCase
; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
; return (mkMatchGroupName origin new_ms, ms_fvs) } ; return (mkMatchGroupName origin new_ms, ms_fvs) }
...@@ -1097,7 +1099,7 @@ rnGRHS' :: HsMatchContext Name ...@@ -1097,7 +1099,7 @@ rnGRHS' :: HsMatchContext Name
-> GRHS RdrName (Located (body RdrName)) -> GRHS RdrName (Located (body RdrName))
-> RnM (GRHS Name (Located (body Name)), FreeVars) -> RnM (GRHS Name (Located (body Name)), FreeVars)
rnGRHS' ctxt rnBody (GRHS guards rhs) rnGRHS' ctxt rnBody (GRHS guards rhs)
= do { pattern_guards_allowed <- xoptM Opt_PatternGuards = do { pattern_guards_allowed <- xoptM LangExt.PatternGuards
; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ -> ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->
rnBody rhs rnBody rhs
......
...@@ -83,6 +83,7 @@ import Data.List ...@@ -83,6 +83,7 @@ import Data.List
import Data.Function ( on ) import Data.Function ( on )
import ListSetOps ( minusList ) import ListSetOps ( minusList )
import Constants ( mAX_TUPLE_SIZE ) import Constants ( mAX_TUPLE_SIZE )
import qualified GHC.LanguageExtensions as LangExt
{- {-
********************************************************* *********************************************************
...@@ -302,7 +303,7 @@ lookupTopBndrRn_maybe rdr_name ...@@ -302,7 +303,7 @@ lookupTopBndrRn_maybe rdr_name
-- See Note [Type and class operator definitions] -- See Note [Type and class operator definitions]
let occ = rdrNameOcc rdr_name let occ = rdrNameOcc rdr_name
; when (isTcOcc occ && isSymOcc occ) ; when (isTcOcc occ && isSymOcc occ)
(do { op_ok <- xoptM Opt_TypeOperators (do { op_ok <- xoptM LangExt.TypeOperators
; unless op_ok (addErr (opDeclErr rdr_name)) }) ; unless op_ok (addErr (opDeclErr rdr_name)) })
; env <- getGlobalRdrEnv ; env <- getGlobalRdrEnv
...@@ -712,7 +713,7 @@ lookupOccRn rdr_name ...@@ -712,7 +713,7 @@ lookupOccRn rdr_name
lookupKindOccRn :: RdrName -> RnM Name lookupKindOccRn :: RdrName -> RnM Name
-- Looking up a name occurring in a kind -- Looking up a name occurring in a kind
lookupKindOccRn rdr_name lookupKindOccRn rdr_name
= do { typeintype <- xoptM Opt_TypeInType = do { typeintype <- xoptM LangExt.TypeInType
; if | typeintype -> lookupTypeOccRn rdr_name ; if | typeintype -> lookupTypeOccRn rdr_name
-- With -XNoTypeInType, treat any usage of * in kinds as in scope -- With -XNoTypeInType, treat any usage of * in kinds as in scope
-- this is a dirty hack, but then again so was the old * kind. -- this is a dirty hack, but then again so was the old * kind.
...@@ -734,7 +735,7 @@ lookup_demoted :: RdrName -> DynFlags -> RnM Name ...@@ -734,7 +735,7 @@ lookup_demoted :: RdrName -> DynFlags -> RnM Name
lookup_demoted rdr_name dflags lookup_demoted rdr_name dflags
| Just demoted_rdr <- demoteRdrName rdr_name | Just demoted_rdr <- demoteRdrName rdr_name
-- Maybe it's the name of a *data* constructor -- Maybe it's the name of a *data* constructor
= do { data_kinds <- xoptM Opt_DataKinds = do { data_kinds <- xoptM LangExt.DataKinds