Merge pull request #98 from zliu41/extensions

zliu41 · web-flow · commit 4af6ade52f37 · 2020-11-16T22:37:38.000-08:00
Make applyRefactoring take GHC extensions
diff --git a/apply-refact.cabal b/apply-refact.cabal
@@ -35,6 +35,7 @@ library
                , refact >= 0.2
                , ghc-exactprint >= 0.6.3.3
                , ghc >= 8.6
+               , ghc-boot-th
                , containers >= 0.6.0.1 && < 0.7
                , extra >= 1.7.3
                , syb >= 0.7.1
@@ -43,6 +44,9 @@ library
                , filemanip >= 0.3.6.3 && < 0.4
                , unix-compat >= 0.5.2
                , directory >= 1.3
+  if impl(ghc >= 8.8)
+    build-depends:
+      ghc-lib-parser-ex >= 8.10.0.16
   hs-source-dirs:      src
   default-language:    Haskell2010
 
@@ -76,6 +80,9 @@ executable refactor
                , unix-compat
                , filepath
                , transformers
+  if impl(ghc >= 8.8)
+    build-depends:
+      ghc-lib-parser-ex >= 8.10.0.16
 
 Test-Suite test
   type:                exitcode-stdio-1.0
@@ -110,3 +117,6 @@ Test-Suite test
                , filepath
                , silently
                , transformers
+  if impl(ghc >= 8.8)
+    build-depends:
+      ghc-lib-parser-ex >= 8.10.0.16
diff --git a/cabal.project b/cabal.project
@@ -0,0 +1,2 @@
+packages: *.cabal
+constraints: ghc-lib-parser-ex -auto +no-ghc-lib
diff --git a/src/Refact/Apply.hs b/src/Refact/Apply.hs
@@ -1,15 +1,24 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE TupleSections #-}
 
 module Refact.Apply
-  ( runRefactoring
-  , applyRefactorings
+  ( applyRefactorings
+  , runRefactoring
+  , parseExtensions
   ) where
 
-import Language.Haskell.GHC.ExactPrint.Parsers (parseModuleWithOptions)
+import Data.List
+import GHC.LanguageExtensions.Type (Extension(..))
 import Refact.Fixity
 import Refact.Internal
 import Refact.Types
 
+#if __GLASGOW_HASKELL__ <= 806
+import DynFlags (FlagSpec(flagSpecFlag, flagSpecName), xFlags)
+#else
+import Language.Haskell.GhclibParserEx.GHC.Driver.Session (impliedXFlags, readExtension)
+#endif
+
 -- | Apply a set of refactorings as supplied by hlint
 applyRefactorings
   :: Maybe (Int, Int)
@@ -25,8 +34,106 @@ applyRefactorings
   -- prior to it which has an overlapping source span and is not filtered out.
   -> FilePath
   -- ^ Target file
+  -> ([Extension], [Extension])
+  -- ^ Enabled and disabled extensions. These are in addition to the @LANGUAGE@ pragmas
+  -- in the target file. When they conflict with the @LANGUAGE@ pragmas, pragmas win.
   -> IO String
-applyRefactorings optionsPos inp file = do
+applyRefactorings optionsPos inp file exts = do
   (as, m) <- either (onError "apply") (uncurry applyFixities)
-              =<< parseModuleWithOptions rigidLayout file
+              =<< parseModuleWithArgs exts file
   apply optionsPos False ((mempty,) <$> inp) file Silent as m
+
+-- | Parse the input into (enabled extensions, disabled extensions, invalid input).
+-- Implied extensions are automatically added. For example, @FunctionalDependencies@
+-- implies @MultiParamTypeClasses@, and @RebindableSyntax@ implies @NoImplicitPrelude@.
+--
+-- The input is processed from left to right. An extension (e.g., @StarIsType@)
+-- may be overridden later (e.g., by @NoStarIsType@).
+--
+-- Extensions that appear earlier in the input will appear later in the output.
+-- Implied extensions appear in the end. If an extension occurs multiple times in the input,
+-- the last one is used.
+--
+-- >>> parseExtensions ["GADTs", "RebindableSyntax", "StarIsType", "GADTs", "InvalidExtension", "NoStarIsType"]
+-- ([GADTs, RebindableSyntax, GADTSyntax, MonoLocalBinds], [StarIsType, ImplicitPrelude], ["InvalidExtension"])
+parseExtensions :: [String] -> ([Extension], [Extension], [String])
+parseExtensions = addImplied . foldl' f mempty
+  where
+    f :: ([Extension], [Extension], [String]) -> String -> ([Extension], [Extension], [String])
+    f (ys, ns, is) ('N' : 'o' : s) | Just ext <- readExtension s =
+      (delete ext ys, ext : delete ext ns, is)
+    f (ys, ns, is) s | Just ext <- readExtension s =
+      (ext : delete ext ys, delete ext ns, is)
+    f (ys, ns, is) s = (ys, ns, s : is)
+
+    addImplied :: ([Extension], [Extension], [String]) -> ([Extension], [Extension], [String])
+    addImplied (ys, ns, is) = (ys ++ impliedOn, ns ++ impliedOff, is)
+      where
+        impliedOn = [b | ext <- ys, (a, True, b) <- impliedXFlags, a == ext]
+        impliedOff = [b | ext <- ys, (a, False, b) <- impliedXFlags, a == ext]
+
+#if __GLASGOW_HASKELL__ <= 806
+readExtension :: String -> Maybe Extension
+readExtension s = flagSpecFlag <$> find ((== s) . flagSpecName) xFlags
+
+-- | Copied from "Language.Haskell.GhclibParserEx.GHC.Driver.Session", in order to
+-- support GHC 8.6
+impliedXFlags :: [(Extension, Bool, Extension)]
+impliedXFlags
+-- See Note [Updating flag description in the User's Guide]
+  = [ (RankNTypes,                True, ExplicitForAll)
+    , (QuantifiedConstraints,     True, ExplicitForAll)
+    , (ScopedTypeVariables,       True, ExplicitForAll)
+    , (LiberalTypeSynonyms,       True, ExplicitForAll)
+    , (ExistentialQuantification, True, ExplicitForAll)
+    , (FlexibleInstances,         True, TypeSynonymInstances)
+    , (FunctionalDependencies,    True, MultiParamTypeClasses)
+    , (MultiParamTypeClasses,     True, ConstrainedClassMethods)  -- c.f. #7854
+    , (TypeFamilyDependencies,    True, TypeFamilies)
+
+    , (RebindableSyntax, False, ImplicitPrelude)      -- NB: turn off!
+
+    , (DerivingVia, True, DerivingStrategies)
+
+    , (GADTs,            True, GADTSyntax)
+    , (GADTs,            True, MonoLocalBinds)
+    , (TypeFamilies,     True, MonoLocalBinds)
+
+    , (TypeFamilies,     True, KindSignatures)  -- Type families use kind signatures
+    , (PolyKinds,        True, KindSignatures)  -- Ditto polymorphic kinds
+
+    -- TypeInType is now just a synonym for a couple of other extensions.
+    , (TypeInType,       True, DataKinds)
+    , (TypeInType,       True, PolyKinds)
+    , (TypeInType,       True, KindSignatures)
+
+    -- AutoDeriveTypeable is not very useful without DeriveDataTypeable
+    , (AutoDeriveTypeable, True, DeriveDataTypeable)
+
+    -- We turn this on so that we can export associated type
+    -- type synonyms in subordinates (e.g. MyClass(type AssocType))
+    , (TypeFamilies,     True, ExplicitNamespaces)
+    , (TypeOperators, True, ExplicitNamespaces)
+
+    , (ImpredicativeTypes,  True, RankNTypes)
+
+        -- Record wild-cards implies field disambiguation
+        -- Otherwise if you write (C {..}) you may well get
+        -- stuff like " 'a' not in scope ", which is a bit silly
+        -- if the compiler has just filled in field 'a' of constructor 'C'
+    , (RecordWildCards,     True, DisambiguateRecordFields)
+
+    , (ParallelArrays, True, ParallelListComp)
+
+    , (JavaScriptFFI, True, InterruptibleFFI)
+
+    , (DeriveTraversable, True, DeriveFunctor)
+    , (DeriveTraversable, True, DeriveFoldable)
+
+    -- Duplicate record fields require field disambiguation
+    , (DuplicateRecordFields, True, DisambiguateRecordFields)
+
+    , (TemplateHaskell, True, TemplateHaskellQuotes)
+    , (Strict, True, StrictData)
+  ]
+#endif
diff --git a/src/Refact/Internal.hs b/src/Refact/Internal.hs
@@ -12,6 +12,8 @@
 module Refact.Internal
   ( apply
   , runRefactoring
+  , addExtensionsToFlags
+  , parseModuleWithArgs
 
   -- * Support for runPipe in the main process
   , Verbosity(..)
@@ -45,9 +47,16 @@ import qualified Data.Map as Map
 import Data.Maybe
 import Data.List
 import Data.Ord
+import DynFlags hiding (initDynFlags)
+import HeaderInfo (getOptions)
+import HscTypes (handleSourceError)
 import GHC.IO.Exception (IOErrorType(..))
+import GHC.LanguageExtensions.Type (Extension(..))
+import Panic (handleGhcException)
+import StringBuffer (stringToStringBuffer)
 import System.IO
 import System.IO.Error (mkIOError)
+import System.IO.Extra
 
 import Debug.Trace
 
@@ -649,3 +658,33 @@ doRename ss = everywhere (mkT rename)
           (s, n) = (GHC.occNameString v, GHC.occNameSpace v)
           s' = fromMaybe s (lookup s ss)
 -}
+
+addExtensionsToFlags
+  :: [Extension] -> [Extension] -> FilePath -> DynFlags
+  -> IO (Either String DynFlags)
+addExtensionsToFlags es ds fp flags = catchErrors $ do
+    (stringToStringBuffer -> buf) <- readFileUTF8' fp
+    let opts = getOptions flags buf fp
+        withExts = flip (foldl' xopt_unset) ds
+                      . flip (foldl' xopt_set) es
+                      $ flags
+    (withPragmas, _, _) <- parseDynamicFilePragma withExts opts
+    pure . Right $ withPragmas `gopt_set` Opt_KeepRawTokenStream
+  where
+    catchErrors = handleGhcException (pure . Left . show)
+                . handleSourceError (pure . Left . show)
+
+parseModuleWithArgs
+  :: ([Extension], [Extension])
+  -> FilePath
+  -> IO (Either Errors (Anns, GHC.ParsedSource))
+parseModuleWithArgs (es, ds) fp = ghcWrapper $ do
+  initFlags <- initDynFlags fp
+  eflags <- liftIO $ addExtensionsToFlags es ds fp initFlags
+  case eflags of
+    -- TODO: report error properly.
+    Left err -> pure . Left $ mkErr initFlags (UnhelpfulSpan mempty) err
+    Right flags -> do
+      _ <- GHC.setSessionDynFlags flags
+      res <- parseModuleApiAnnsWithCppInternal defaultCppOptions flags fp
+      pure $ postParseTransform res rigidLayout
diff --git a/src/Refact/Run.hs b/src/Refact/Run.hs
@@ -1,38 +1,24 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE ViewPatterns #-}
 
 module Refact.Run (refactMain, runPipe) where
 
-import Language.Haskell.GHC.ExactPrint
-import qualified Language.Haskell.GHC.ExactPrint.Parsers as EP
-  ( defaultCppOptions
-  , ghcWrapper
-  , initDynFlags
-  , parseModuleApiAnnsWithCppInternal
-  , postParseTransform
-  )
 import Language.Haskell.GHC.ExactPrint.Utils
 
+import Refact.Apply (parseExtensions)
 import qualified Refact.Types as R
 import Refact.Types hiding (SrcSpan)
 import Refact.Fixity
-import Refact.Internal (Errors, Verbosity(..), apply, onError, mkErr, rigidLayout)
+import Refact.Internal
+  ( Verbosity(..)
+  , apply
+  , onError
+  , parseModuleWithArgs
+  )
 import Refact.Options (Options(..), optionsWithHelp)
 
-import DynFlags
-import HeaderInfo (getOptions)
-import HscTypes (handleSourceError)
-import qualified GHC (setSessionDynFlags, ParsedSource)
-import Panic (handleGhcException)
-import SrcLoc
-import StringBuffer (stringToStringBuffer)
-import GHC.LanguageExtensions.Type (Extension(..))
-
 import Control.Monad
-import Control.Monad.IO.Class (MonadIO(..))
 import Data.List hiding (find)
-import qualified Data.List as List
 import Data.Maybe
 import Data.Version
 import Options.Applicative
@@ -87,49 +73,6 @@ filterFilename = do
       | "Setup.hs" `isInfixOf` x = False
       | otherwise                 = True
 
--- | Parse the input into a list of enabled extensions and a list of disabled extensions.
-parseExtensions :: [String] -> ([Extension], [Extension])
-parseExtensions = foldl' f ([], [])
-  where
-    f :: ([Extension], [Extension]) -> String -> ([Extension], [Extension])
-    f (ys, ns) ('N' : 'o' : s) | Just ext <- readExtension s =
-      (delete ext ys, ext : delete ext ns)
-    f (ys, ns) s | Just ext <- readExtension s =
-      (ext : delete ext ys, delete ext ns)
-    -- ignore unknown extensions
-    f (ys, ns) _ = (ys, ns)
-
-    readExtension :: String -> Maybe Extension
-    readExtension s = flagSpecFlag <$> List.find ((== s) . flagSpecName) xFlags
-
-addExtensionsToFlags
-  :: [Extension] -> [Extension] -> FilePath -> DynFlags
-  -> IO (Either String DynFlags)
-addExtensionsToFlags es ds fp flags = catchErrors $ do
-    (stringToStringBuffer -> buf) <- readFileUTF8' fp
-    let opts = getOptions flags buf fp
-        withExts = flip (foldl' xopt_unset) ds
-                      . flip (foldl' xopt_set) es
-                      $ flags
-    (withPragmas, _, _) <- parseDynamicFilePragma withExts opts
-    pure . Right $ withPragmas `gopt_set` Opt_KeepRawTokenStream
-  where
-    catchErrors = handleGhcException (pure . Left . show)
-                . handleSourceError (pure . Left . show)
-
-parseModuleWithArgs :: [String] -> FilePath -> IO (Either Errors (Anns, GHC.ParsedSource))
-parseModuleWithArgs exts fp = EP.ghcWrapper $ do
-  let (es, ds) = parseExtensions exts
-  initFlags <- EP.initDynFlags fp
-  eflags <- liftIO $ addExtensionsToFlags es ds fp initFlags
-  case eflags of
-    -- TODO: report error properly.
-    Left err -> pure . Left $ mkErr initFlags (UnhelpfulSpan mempty) err
-    Right flags -> do
-      _ <- GHC.setSessionDynFlags flags
-      res <- EP.parseModuleApiAnnsWithCppInternal EP.defaultCppOptions flags fp
-      return $ EP.postParseTransform res rigidLayout
-
 runPipe :: Options -> FilePath  -> IO ()
 runPipe Options{..} file = do
   let verb = optionsVerbosity
@@ -141,8 +84,11 @@ runPipe Options{..} file = do
 
   output <- if null inp then readFileUTF8' file else do
     when (verb == Loud) (traceM "Parsing module")
+    let (enabledExts, disabledExts, invalidExts) = parseExtensions optionsLanguage
+    unless (null invalidExts) . when (verb >= Normal) . putStrLn $
+      "Invalid extensions: " ++ intercalate ", " invalidExts
     (as, m) <- either (onError "runPipe") (uncurry applyFixities)
-                =<< parseModuleWithArgs optionsLanguage file
+                =<< parseModuleWithArgs (enabledExts, disabledExts) file
     when optionsDebug (putStrLn (showAnnData as 0 m))
     apply optionsPos optionsStep inp file verb as m
 

Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,2 @@`
	`1`	`+packages: *.cabal`
	`2`	`+constraints: ghc-lib-parser-ex -auto +no-ghc-lib`