Merge pull request #689 from shayne-fletcher-da/issue-681

langexts explcitily enabled/disabled

Author: ndmitchell

src/GHC/Util.hs

@@ -11,6 +11,7 @@ module GHC.Util (
   , getMessages
   , SDoc
   , Located
+  , hseToGhcExtension
   -- Temporary : Export these so GHC doesn't consider them unused and
   -- tell weeder to ignore them.
   , isAtom, addParen, paren, isApp, isOpApp, isAnyApp, isDot, isSection, isDotApp
@@ -38,6 +39,8 @@ import "ghc-lib-parser" HeaderInfo
 import Data.List
 import System.FilePath
 import Language.Preprocessor.Unlit
+import qualified Language.Haskell.Exts.Extension as HSE
+import qualified Data.Map.Strict as Map
 
 fakeSettings :: Settings
 fakeSettings = Settings
@@ -83,13 +86,21 @@ baseDynFlags :: DynFlags
 baseDynFlags = foldl' xopt_set
              (defaultDynFlags fakeSettings fakeLlvmConfig) enabledExtensions
 
-parsePragmasIntoDynFlags ::
-  DynFlags -> FilePath -> String -> IO (Either String DynFlags)
-parsePragmasIntoDynFlags flags filepath str =
+-- | Adjust the input 'DynFlags' to take into account language
+-- extensions to explicitly enable/disable as well as language
+-- extensions enabled by pragma in the source.
+parsePragmasIntoDynFlags :: DynFlags
+                         -> ([Extension], [Extension])
+                         -> FilePath
+                         -> String
+                         -> IO (Either String DynFlags)
+parsePragmasIntoDynFlags flags (enable, disable) filepath str =
   catchErrors $ do
     let opts = getOptions flags (stringToStringBuffer str) filepath
     (flags, _, _) <- parseDynamicFilePragma flags opts
-    return $ Right flags
+    let flags' =  foldl' xopt_set flags enable
+    let flags'' = foldl' xopt_unset flags' disable
+    return $ Right flags''
   where
     catchErrors :: IO (Either String DynFlags) -> IO (Either String DynFlags)
     catchErrors act = handleGhcException reportErr
@@ -195,3 +206,12 @@ isSection x = case x of
 isDotApp :: HsExpr GhcPs -> Bool
 isDotApp (OpApp _ _ (L _ op) _) = isDot op
 isDotApp _ = False
+
+-- | A mapping from 'HSE.KnownExtension' values to their
+-- 'GHC.LanguageExtensions.Type.Extension' equivalents.
+hseToGhcExtension :: Map.Map HSE.KnownExtension Extension
+hseToGhcExtension =
+  let ghcExts = Map.fromList [(show x, x) | x <- [Cpp .. StarIsType]]
+  in
+    Map.fromList [ (x, ext) | x <- [minBound .. maxBound]
+                 , Just ext <- [Map.lookup (show x) ghcExts] ]

src/HSE/All.hs

@@ -24,6 +24,7 @@ import Data.List.Extra
 import Data.Maybe
 import Timing
 import Language.Preprocessor.Cpphs
+import Data.Either
 import Data.Set (Set)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
@@ -37,6 +38,7 @@ import qualified "ghc-lib-parser" FastString
 import qualified "ghc-lib-parser" SrcLoc as GHC
 import qualified "ghc-lib-parser" ErrUtils
 import qualified "ghc-lib-parser" Outputable
+import qualified "ghc-lib-parser" GHC.LanguageExtensions.Type as GHC
 
 vars :: FreeVars a => a -> [String]
 freeVars :: FreeVars a => a -> Set String
@@ -229,6 +231,17 @@ ghcFailOpParseModuleEx ppstr file str (loc, err) = do
                ErrUtils.pprLocErrMsg (ErrUtils.mkPlainErrMsg baseDynFlags loc err)
    return $ Left $ ParseError sl msg pe
 
+-- | Produce a pair of lists from a 'ParseFlags' value representing
+-- language extensions to explicitly enable/disable.
+ghcExtensionsFromParseFlags :: ParseFlags
+                             -> ([GHC.Extension], [GHC.Extension])
+ghcExtensionsFromParseFlags ParseFlags {hseFlags=ParseMode {extensions=exts}}=
+   partitionEithers $ mapMaybe toEither exts
+   where
+     toEither ke = case ke of
+       EnableExtension e  -> Left  <$> Map.lookup e hseToGhcExtension
+       DisableExtension e -> Right <$> Map.lookup e hseToGhcExtension
+
 -- | Parse a Haskell module. Applies the C pre processor, and uses
 -- best-guess fixity resolution if there are ambiguities.  The
 -- filename @-@ is treated as @stdin@. Requires some flags (often
@@ -242,7 +255,8 @@ parseModuleEx flags file str = timedIO "Parse" file $ do
                     | otherwise -> readFileUTF8' file
         str <- return $ fromMaybe str $ stripPrefix "\65279" str -- remove the BOM if it exists, see #130
         ppstr <- runCpp (cppFlags flags) file str
-        dynFlags <- parsePragmasIntoDynFlags baseDynFlags file ppstr
+        let enableDisableExts = ghcExtensionsFromParseFlags flags
+        dynFlags <- parsePragmasIntoDynFlags baseDynFlags enableDisableExts file ppstr
         case dynFlags of
           Right ghcFlags ->
             case (parseFileContentsWithComments (mkMode flags file) ppstr, parseFileGhcLib file ppstr ghcFlags) of