diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,7 @@ +v0.9.2.0 + + * #110, Support GHC 9.0.1 + v0.9.1.0 * #109, Use the correct DynFlags when parsing refactoring templates diff --git a/apply-refact.cabal b/apply-refact.cabal --- a/apply-refact.cabal +++ b/apply-refact.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: apply-refact -version: 0.9.1.0 +version: 0.9.2.0 synopsis: Perform refactorings specified by the refact library. description: Perform refactorings specified by the refact library. It is primarily used with HLint's --refactor flag. license: BSD-3-Clause @@ -18,7 +18,7 @@ , tests/examples/*.hs , tests/examples/*.hs.refact , tests/examples/*.hs.expected -tested-with: GHC == 8.10.3, GHC == 8.8.4, GHC == 8.6.5 +tested-with: GHC == 9.0.1, GHC == 8.10.3, GHC == 8.8.4, GHC == 8.6.5 source-repository head @@ -33,7 +33,7 @@ GHC-Options: -Wall build-depends: base >=4.12 && < 5 , refact >= 0.2 - , ghc-exactprint >= 0.6.3.3 + , ghc-exactprint >= 0.6.4 , ghc >= 8.6 , ghc-boot-th , containers >= 0.6.0.1 && < 0.7 @@ -46,6 +46,19 @@ , unix-compat >= 0.5.2 , directory >= 1.3 , uniplate >= 1.6.13 + default-extensions: FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GADTs + , LambdaCase + , MultiParamTypeClasses + , NamedFieldPuns + , PolyKinds + , RankNTypes + , ScopedTypeVariables + , TupleSections + , TypeApplications + , TypeOperators hs-source-dirs: src default-language: Haskell2010 @@ -80,6 +93,19 @@ , filepath , transformers , uniplate + default-extensions: FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GADTs + , LambdaCase + , MultiParamTypeClasses + , NamedFieldPuns + , PolyKinds + , RankNTypes + , ScopedTypeVariables + , TupleSections + , TypeApplications + , TypeOperators Test-Suite test type: exitcode-stdio-1.0 @@ -93,25 +119,38 @@ Refact.Options Refact.Run Refact.Utils - GHC-Options: -threaded - Default-language: Haskell2010 - Build-depends: tasty - , tasty-golden - , tasty-expected-failure - , base - , refact - , ghc-exactprint - , ghc - , ghc-boot-th - , containers - , extra - , syb - , process - , directory - , optparse-applicative - , filemanip - , unix-compat - , filepath - , silently - , transformers - , uniplate + ghc-options: -threaded + default-language: Haskell2010 + build-depends: tasty + , tasty-golden + , tasty-expected-failure + , base + , refact + , ghc-exactprint + , ghc + , ghc-boot-th + , containers + , extra + , syb + , process + , directory + , optparse-applicative + , filemanip + , unix-compat + , filepath + , silently + , transformers + , uniplate + default-extensions: FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GADTs + , LambdaCase + , MultiParamTypeClasses + , NamedFieldPuns + , PolyKinds + , RankNTypes + , ScopedTypeVariables + , TupleSections + , TypeApplications + , TypeOperators diff --git a/src/Refact/Apply.hs b/src/Refact/Apply.hs --- a/src/Refact/Apply.hs +++ b/src/Refact/Apply.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TupleSections #-} - module Refact.Apply ( applyRefactorings , applyRefactorings' diff --git a/src/Refact/Fixity.hs b/src/Refact/Fixity.hs --- a/src/Refact/Fixity.hs +++ b/src/Refact/Fixity.hs @@ -1,12 +1,9 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -module Refact.Fixity (applyFixities) where -import SrcLoc +module Refact.Fixity (applyFixities) where import Refact.Utils -import BasicTypes (Fixity(..), defaultFixity, compareFixity, negateFixity, FixityDirection(..), SourceText(..)) #if __GLASGOW_HASKELL__ >= 810 import GHC.Hs @@ -15,9 +12,20 @@ import HsExtension hiding (noExt) #endif +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Parser.Annotation +import GHC.Types.Basic (Fixity(..), defaultFixity, compareFixity, negateFixity, FixityDirection(..), SourceText(..)) +import GHC.Types.Name.Occurrence +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc +#else import ApiAnnotation +import BasicTypes (Fixity(..), defaultFixity, compareFixity, negateFixity, FixityDirection(..), SourceText(..)) import RdrName import OccName +import SrcLoc +#endif + import Data.Generics hiding (Fixity) import Data.List import Data.Maybe @@ -105,13 +113,12 @@ moveDelta oldAnn oldKey newKey let res = L loc (NegApp noExt new_e neg_name) key = mkAnnKey res - ak = AnnKey loc (CN "OpApp") + ak = AnnKey (srcSpanToAnnSpan loc) (CN "OpApp") opAnn <- gets (fromMaybe annNone . Map.lookup ak) negAnns <- gets (fromMaybe annNone . Map.lookup (mkAnnKey e1)) modify $ Map.insert key (annNone { annEntryDelta = annEntryDelta opAnn, annsDP = annsDP negAnns }) modify $ Map.delete (mkAnnKey e1) return res - where loc' = combineLocs neg_arg e2 (nofix_error, associate_right) = compareFixity negateFixity fix2 diff --git a/src/Refact/Internal.hs b/src/Refact/Internal.hs --- a/src/Refact/Internal.hs +++ b/src/Refact/Internal.hs @@ -1,13 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module Refact.Internal ( apply , runRefactoring @@ -43,49 +38,68 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Tuple.Extra +import Debug.Trace + +import qualified GHC hiding (parseModule) + +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Data.Bag +import GHC.Data.StringBuffer (stringToStringBuffer) +import GHC.Driver.Session hiding (initDynFlags) +import GHC.Driver.Types (handleSourceError) +import GHC.Parser.Header (getOptions) +import qualified GHC.Types.Name as GHC +import qualified GHC.Types.Name.Reader as GHC +import GHC.Types.SrcLoc hiding (spans) +import GHC.Utils.Error +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Utils.Panic (handleGhcException) +#else import DynFlags hiding (initDynFlags) -import FastString (unpackFS) import HeaderInfo (getOptions) import HscTypes (handleSourceError) -import GHC.IO.Exception (IOErrorType(..)) -import GHC.LanguageExtensions.Type (Extension(..)) -import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Annotate -import Language.Haskell.GHC.ExactPrint.Delta -import Language.Haskell.GHC.ExactPrint.Parsers -import Language.Haskell.GHC.ExactPrint.Print -import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, GhcTc, GhcRn) -import Language.Haskell.GHC.ExactPrint.Utils +import qualified Name as GHC +import Outputable hiding ((<>)) import Panic (handleGhcException) +import qualified RdrName as GHC +import SrcLoc hiding (spans) import StringBuffer (stringToStringBuffer) -import System.IO.Error (mkIOError) -import System.IO.Extra -import System.IO.Unsafe (unsafePerformIO) - -import Debug.Trace +#endif #if __GLASGOW_HASKELL__ >= 810 import GHC.Hs.Expr as GHC hiding (Stmt) import GHC.Hs.ImpExp import GHC.Hs hiding (Pat, Stmt) -import ErrUtils -import Bag -#else +#elif __GLASGOW_HASKELL__ <= 808 import HsExpr as GHC hiding (Stmt) import HsImpExp import HsSyn hiding (Pat, Stmt, noExt) #endif -import Outputable hiding ((<>)) -import SrcLoc hiding (spans) -import qualified GHC hiding (parseModule) -import qualified Name as GHC -import qualified RdrName as GHC +#if __GLASGOW_HASKELL__ == 810 +import Bag +import ErrUtils +#endif +import GHC.IO.Exception (IOErrorType(..)) +import GHC.LanguageExtensions.Type (Extension(..)) +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Annotate +import Language.Haskell.GHC.ExactPrint.Delta +import Language.Haskell.GHC.ExactPrint.Parsers +import Language.Haskell.GHC.ExactPrint.Print +import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, GhcTc, GhcRn) +import Language.Haskell.GHC.ExactPrint.Utils hiding (rs) +import System.IO.Error (mkIOError) +import System.IO.Extra +import System.IO.Unsafe (unsafePerformIO) + import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R import Refact.Utils (Stmt, Pat, Name, Decl, M, Module, Expr, Type, FunBind, AnnKeyMap - , modifyAnnKey, replaceAnnKey, Import, toGhcSrcSpan, toGhcSrcSpan', setSrcSpanFile) + , pattern RealSrcSpan' + , modifyAnnKey, replaceAnnKey, Import, toGhcSrcSpan, toGhcSrcSpan' + , annSpanToSrcSpan, srcSpanToAnnSpan, setSrcSpanFile, setAnnSpanFile, getAnnSpan) #if __GLASGOW_HASKELL__ >= 810 type Errors = ErrorMessages @@ -97,7 +111,7 @@ onError _ = error . show #endif -#if __GLASGOW_HASKELL__ <= 806 +#if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900 composeSrcSpan :: a -> a composeSrcSpan = id @@ -129,8 +143,9 @@ toGhcSS <- maybe ( case getLoc m0 of - UnhelpfulSpan s -> fail $ "Module has UnhelpfulSpan: " ++ unpackFS s - RealSrcSpan s -> pure $ toGhcSrcSpan' (srcSpanFile s) + UnhelpfulSpan s -> fail $ "Module has UnhelpfulSpan: " ++ show s + RealSrcSpan' s -> + pure $ toGhcSrcSpan' (srcSpanFile s) ) (pure . toGhcSrcSpan) mbfile @@ -294,18 +309,19 @@ , annPriorComments = map (first change) annPriorComments } changeComment (AnnComment d, dp) = (AnnComment (change d), dp) changeComment e = e - change old@Comment{..}= if ss2pos commentIdentifier == ss2pos pos + change old@Comment{..}= if ss2pos (annSpanToSrcSpan commentIdentifier) == ss2pos pos then old { commentContents = newComment} else old Delete{rtype, pos} -> pure (as, f m, keyMap) where + annSpan = srcSpanToAnnSpan pos f = case rtype of - Stmt -> doDeleteStmt ((/= pos) . getLoc) - Import -> doDeleteImport ((/= pos) . getLoc) + Stmt -> doDeleteStmt ((/= annSpan) . getAnnSpan) + Import -> doDeleteImport ((/= annSpan) . getAnnSpan) _ -> id InsertComment{..} -> do - exprkey <- mkAnnKey <$> findOrError @(HsDecl GhcPs) m pos + exprkey <- mkAnnKey <$> findOrError @(HsDecl GhcPs) m (srcSpanToAnnSpan pos) pure (insertComment exprkey newComment as, m, keyMap) RemoveAsKeyword{..} -> pure (as, removeAsKeyword m, keyMap) @@ -313,7 +329,7 @@ removeAsKeyword = transformBi go go :: LImportDecl GHC.GhcPs -> LImportDecl GHC.GhcPs go imp@(GHC.L l i) - | l == pos = GHC.L l (i { ideclAs = Nothing }) + | srcSpanToAnnSpan l == srcSpanToAnnSpan pos = GHC.L l (i { ideclAs = Nothing }) | otherwise = imp droppedComments :: Anns -> Module -> AnnKeyMap -> Bool @@ -326,8 +342,8 @@ keySpan (AnnKey ss _) = ss - allSpans :: Set SrcSpan - allSpans = Set.fromList (universeBi m) + allSpans :: Set AnnSpan + allSpans = Set.fromList . fmap srcSpanToAnnSpan $ universeBi m -- Specialised parsers mkErr :: GHC.DynFlags -> SrcSpan -> String -> Errors @@ -340,7 +356,11 @@ parseModuleName :: SrcSpan -> Parser (GHC.Located GHC.ModuleName) parseModuleName ss _ _ s = let newMN = GHC.L ss (GHC.mkModuleName s) - newAnns = relativiseApiAnns newMN (Map.empty, Map.empty) +#if __GLASGOW_HASKELL__ >= 900 + newAnns = relativiseApiAnns newMN (GHC.ApiAnns mempty Nothing mempty mempty) +#else + newAnns = relativiseApiAnns newMN mempty +#endif in pure (newAnns, newMN) parseBind :: Parser (GHC.LHsBind GHC.GhcPs) parseBind dyn fname s = @@ -417,7 +437,7 @@ -- g is usually modifyAnnKey -- f is usually a function which checks the locations are equal resolveRdrName' :: (a -> b -> M a) -- How to combine the value to insert and the replaced value - -> (SrcSpan -> M b) -- How to find the new value, when given the location it is in + -> (AnnSpan -> M b) -- How to find the new value, when given the location it is in -> a -- The old thing which we are going to possibly replace -> [(String, SrcSpan)] -- Substs -> GHC.RdrName -- The name of the position in the template @@ -427,29 +447,37 @@ case name of -- Todo: this should replace anns as well? GHC.Unqual (GHC.occNameString . GHC.occName -> oname) - | Just ss <- lookup oname subs -> f ss >>= g old + | Just ss <- lookup oname subs -> f (srcSpanToAnnSpan ss) >>= g old _ -> pure old resolveRdrName :: (Data old, Data a) => a - -> (SrcSpan -> M (Located old)) + -> (AnnSpan -> M (Located old)) -> Located old -> [(String, SrcSpan)] -> GHC.RdrName -> M (Located old) resolveRdrName m = resolveRdrName' (modifyAnnKey m) +badAnnSpan :: AnnSpan +badAnnSpan = +#if __GLASGOW_HASKELL__ >= 900 + badRealSrcSpan +#else + GHC.noSrcSpan +#endif + insertComment :: AnnKey -> String -> Map.Map AnnKey Annotation -> Map.Map AnnKey Annotation insertComment k s as = - let comment = Comment s GHC.noSrcSpan Nothing in + let comment = Comment s badAnnSpan Nothing in Map.adjust (\a@Ann{..} -> a { annPriorComments = annPriorComments ++ [(comment, DP (1,0))] , annEntryDelta = DP (1,0) }) k as -- Substitute the template into the original AST. -#if __GLASGOW_HASKELL__ <= 806 +#if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900 doGenReplacement :: forall ast a. (Data ast, Data a) => a @@ -480,7 +508,7 @@ | Just Refl <- eqT @(SrcSpanLess ast) @(HsDecl GHC.GhcPs) , L _ (ValD xvald newBind@FunBind{}) <- decomposeSrcSpan new , Just (oldNoLocal, oldLocal) <- stripLocalBind (decomposeSrcSpan old) - , newLoc@(RealSrcSpan newLocReal) <- getLoc new + , newLoc@(RealSrcSpan' newLocReal) <- getLoc new , p (composeSrcSpan oldNoLocal) = do (anns, keyMap) <- gets fst let n = decomposeSrcSpan new @@ -507,17 +535,27 @@ addAnnWhere oldAnns = let oldAnns' = Map.toList oldAnns po = \case +#if __GLASGOW_HASKELL__ >= 900 + (AnnKey loc con, _) -> + loc == getAnnSpan old && con == CN "Match" && srcSpanFile loc /= newFile +#else (AnnKey loc@(RealSrcSpan r) con, _) -> loc == getLoc old && con == CN "Match" && srcSpanFile r /= newFile _ -> False +#endif pn = \case +#if __GLASGOW_HASKELL__ >= 900 + (AnnKey loc con, _) -> + loc == srcSpanToAnnSpan finalLoc && con == CN "Match" && srcSpanFile loc == newFile +#else (AnnKey loc@(RealSrcSpan r) con, _) -> loc == finalLoc && con == CN "Match" && srcSpanFile r == newFile _ -> False +#endif in fromMaybe oldAnns $ do oldAnn <- snd <$> find po oldAnns' annWhere <- find ((== G GHC.AnnWhere) . fst) (annsDP oldAnn) - let newSortKey = fmap (setSrcSpanFile newFile) <$> annSortKey oldAnn + let newSortKey = fmap (setAnnSpanFile newFile) <$> annSortKey oldAnn newKey <- fst <$> find pn oldAnns' pure $ Map.adjust (\ann -> ann {annsDP = annsDP ann ++ [annWhere], annSortKey = newSortKey}) @@ -526,20 +564,26 @@ -- Expand the SrcSpan of the "GRHS" entry in the new file to include the local binds expandGRHSLoc = \case +#if __GLASGOW_HASKELL__ >= 900 + AnnKey r@(annSpanToSrcSpan -> loc) con +#else AnnKey loc@(RealSrcSpan r) con - | con == CN "GRHS", srcSpanFile r == newFile -> AnnKey (ensureLoc loc) con +#endif + | con == CN "GRHS", srcSpanFile r == newFile -> + AnnKey (srcSpanToAnnSpan $ ensureLoc loc) con other -> other -- If an Anns entry corresponds to the local binds, update its file to point to the new file. updateFile = \case AnnKey loc con - | loc `isSubspanOf` getLoc oldLocal -> AnnKey (setSrcSpanFile newFile loc) con + | annSpanToSrcSpan loc `isSubspanOf` getLoc oldLocal -> + AnnKey (setAnnSpanFile newFile loc) con other -> other -- For each SrcSpan in the new file that is the entire newLoc, set it to finalLoc expandTemplateLoc = \case AnnKey loc con - | loc == newLoc -> AnnKey finalLoc con + | loc == srcSpanToAnnSpan newLoc -> AnnKey (srcSpanToAnnSpan finalLoc) con other -> other newAnns = addLocalBindsToAnns intAnns @@ -585,7 +629,7 @@ newMG = origMG{mg_alts = L locMG [L locMatch newMatch]} newBind = origBind{fun_matches = newMG} -#if __GLASGOW_HASKELL__ <= 806 +#if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900 replaceWorker :: (Annotate a, Data mod) => Anns -> mod @@ -605,7 +649,7 @@ -> IO (Anns, mod, AnnKeyMap) #endif replaceWorker as m keyMap parser seed Replace{..} = do - let replExprLocation = pos + let replExprLocation = srcSpanToAnnSpan pos uniqueName = "template" ++ show seed (relat, template) <- do @@ -617,13 +661,21 @@ (substTransform m subts template) (mergeAnns as relat, keyMap) let lst = listToMaybe . reverse . GHC.occNameString . GHC.rdrNameOcc +#if __GLASGOW_HASKELL__ >= 900 + adjacent (srcSpanEnd -> RealSrcLoc loc1 _) (srcSpanStart -> RealSrcLoc loc2 _) = loc1 == loc2 +#else adjacent (srcSpanEnd -> RealSrcLoc loc1) (srcSpanStart -> RealSrcLoc loc2) = loc1 == loc2 +#endif adjacent _ _ = False -- Return @True@ if the start position of the two spans are on the same line, and differ -- by the given number of columns. diffStartCols :: Int -> SrcSpan -> SrcSpan -> Bool +#if __GLASGOW_HASKELL__ >= 900 + diffStartCols x (srcSpanStart -> RealSrcLoc loc1 _) (srcSpanStart -> RealSrcLoc loc2 _) = +#else diffStartCols x (srcSpanStart -> RealSrcLoc loc1) (srcSpanStart -> RealSrcLoc loc2) = +#endif srcLocLine loc1 == srcLocLine loc2 && srcLocCol loc1 - srcLocCol loc2 == x diffStartCols _ _ _ = False @@ -664,7 +716,7 @@ doBlocks' = map ( \case - L loc (HsDo _ MDoExpr _) -> (loc, 3) + L loc (HsDo _ MDoExpr{} _) -> (loc, 3) L loc _ -> (loc, 2) ) doBlocks @@ -674,7 +726,7 @@ then ann { annEntryDelta = DP (0, 1) } else ann - replacementPred (GHC.L l _) = l == replExprLocation + replacementPred = (== replExprLocation) . getAnnSpan transformation = transformBiM (doGenReplacement m (replacementPred . decomposeSrcSpan) newExpr) runStateT (transformation m) ((newAnns, newKeyMap), False) >>= \case (finalM, ((ensureDoSpace . ensureAppSpace -> finalAs, finalKeyMap), True)) -> @@ -686,7 +738,7 @@ data NotFound = NotFound { nfExpected :: String , nfActual :: Maybe String - , nfLoc :: SrcSpan + , nfLoc :: AnnSpan } renderNotFound :: NotFound -> String @@ -697,7 +749,7 @@ ++ " Location: " ++ showSDocUnsafe (ppr nfLoc) -- Find a given type with a given SrcSpan -findInModule :: forall a modu. (Data a, Data modu) => modu -> SrcSpan -> Either NotFound (GHC.Located a) +findInModule :: forall a modu. (Data a, Data modu) => modu -> AnnSpan -> Either NotFound (GHC.Located a) findInModule m ss = case doTrans m of Just a -> Right a Nothing -> @@ -717,14 +769,12 @@ showType :: forall b. Typeable b => Maybe (GHC.Located b) -> Maybe String showType = fmap $ \_ -> show (typeRep (Proxy @b)) -findLargestExpression :: SrcSpan -> GHC.Located a -> Maybe (GHC.Located a) -findLargestExpression ss e@(GHC.L l _) - | l == ss = Just e - | otherwise = Nothing +findLargestExpression :: forall a. Data a => AnnSpan -> GHC.Located a -> Maybe (GHC.Located a) +findLargestExpression as e@(getAnnSpan -> l) = if l == as then Just e else Nothing findOrError :: forall a modu m. (Data a, Data modu, MonadIO m) - => modu -> SrcSpan -> m (GHC.Located a) + => modu -> AnnSpan -> m (GHC.Located a) findOrError m = either f pure . findInModule m where f nf = liftIO . throwIO $ mkIOError InappropriateType (renderNotFound nf) Nothing Nothing @@ -774,7 +824,7 @@ eflags <- liftIO $ addExtensionsToFlags es ds fp initFlags case eflags of -- TODO: report error properly. - Left err -> pure . Left $ mkErr initFlags (UnhelpfulSpan mempty) err + Left err -> pure . Left $ mkErr initFlags GHC.noSrcSpan err Right flags -> do liftIO $ writeIORef' dynFlagsRef (Just flags) res <- parseModuleApiAnnsWithCppInternal defaultCppOptions flags fp @@ -812,6 +862,7 @@ readExtension :: String -> Maybe Extension readExtension s = flagSpecFlag <$> find ((== s) . flagSpecName) xFlags +#if __GLASGOW_HASKELL__ < 900 -- | Copied from "Language.Haskell.GhclibParserEx.GHC.Driver.Session", in order to -- support GHC 8.6 impliedXFlags :: [(Extension, Bool, Extension)] @@ -875,6 +926,7 @@ , (StandaloneKindSignatures, False, CUSKs) #endif ] +#endif -- TODO: This is added to avoid a breaking change. We should remove it and -- directly pass the `DynFlags` as arguments, before the 0.10 release. diff --git a/src/Refact/Options.hs b/src/Refact/Options.hs --- a/src/Refact/Options.hs +++ b/src/Refact/Options.hs @@ -1,7 +1,6 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} diff --git a/src/Refact/Run.hs b/src/Refact/Run.hs --- a/src/Refact/Run.hs +++ b/src/Refact/Run.hs @@ -1,5 +1,4 @@ {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} module Refact.Run (refactMain, runPipe) where diff --git a/src/Refact/Utils.hs b/src/Refact/Utils.hs --- a/src/Refact/Utils.hs +++ b/src/Refact/Utils.hs @@ -1,9 +1,7 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} module Refact.Utils ( -- * Synonyms Module @@ -16,6 +14,8 @@ , Import , FunBind , AnnKeyMap + , pattern RealSrcLoc' + , pattern RealSrcSpan' -- * Monad , M -- * Utility @@ -23,9 +23,14 @@ , mergeAnns , modifyAnnKey , replaceAnnKey + , getAnnSpan , toGhcSrcSpan , toGhcSrcSpan' + , annSpanToSrcSpan + , srcSpanToAnnSpan + , setAnnSpanFile , setSrcSpanFile + , setRealSrcSpanFile , findParent ) where @@ -36,12 +41,22 @@ import Data.Data import Data.Map.Strict (Map) +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Data.FastString (FastString) +import qualified GHC.Data.FastString as GHC +import qualified GHC.Parser.Annotation as GHC +import qualified GHC.Types.Name.Reader as GHC +import GHC.Types.SrcLoc +import qualified GHC.Types.SrcLoc as GHC +#else import FastString (FastString) +import qualified FastString as GHC import SrcLoc import qualified SrcLoc as GHC import qualified RdrName as GHC import qualified ApiAnnotation as GHC -import qualified FastString as GHC +#endif + import qualified GHC hiding (parseModule) #if __GLASGOW_HASKELL__ >= 810 @@ -70,7 +85,11 @@ type AnnKeyMap = Map AnnKey [AnnKey] +#if __GLASGOW_HASKELL__ >= 900 +type Module = (GHC.Located GHC.HsModule) +#else type Module = (GHC.Located (GHC.HsModule GHC.GhcPs)) +#endif type Expr = GHC.Located (GHC.HsExpr GHC.GhcPs) @@ -86,8 +105,32 @@ type Import = LImportDecl GHC.GhcPs +#if __GLASGOW_HASKELL__ >= 900 +type FunBind = HsMatchContext GHC.GhcPs +#else type FunBind = HsMatchContext GHC.RdrName +#endif +pattern RealSrcLoc' :: RealSrcLoc -> SrcLoc +#if __GLASGOW_HASKELL__ >= 900 +pattern RealSrcLoc' r <- RealSrcLoc r _ where + RealSrcLoc' r = RealSrcLoc r Nothing +#else +pattern RealSrcLoc' r <- RealSrcLoc r where + RealSrcLoc' r = RealSrcLoc r +#endif +{-# COMPLETE RealSrcLoc', UnhelpfulLoc #-} + +pattern RealSrcSpan' :: RealSrcSpan -> SrcSpan +#if __GLASGOW_HASKELL__ >= 900 +pattern RealSrcSpan' r <- RealSrcSpan r _ where + RealSrcSpan' r = RealSrcSpan r Nothing +#else +pattern RealSrcSpan' r <- RealSrcSpan r where + RealSrcSpan' r = RealSrcSpan r +#endif +{-# COMPLETE RealSrcSpan', UnhelpfulSpan #-} + -- | Replaces an old expression with a new expression -- -- Note that usually, new, inp and parent are all the same. @@ -135,14 +178,14 @@ -- | A parent in this case is an element which has the same SrcSpan -findParent :: Data a => GHC.SrcSpan -> Anns -> a -> Maybe AnnKey +findParent :: Data a => AnnSpan -> Anns -> a -> Maybe AnnKey findParent ss as = something (findParentWorker ss as) -- Note that a parent must also have an annotation. findParentWorker :: forall a . (Data a) - => GHC.SrcSpan -> Anns -> a -> Maybe AnnKey + => AnnSpan -> Anns -> a -> Maybe AnnKey findParentWorker oldSS as a - | con == typeRepTyCon (typeRep (Proxy :: Proxy (GHC.Located GHC.RdrName))) && x == typeRep (Proxy :: Proxy GHC.SrcSpan) + | con == typeRepTyCon (typeRep (Proxy :: Proxy (GHC.Located GHC.RdrName))) && x == typeRep (Proxy :: Proxy AnnSpan) = if ss == oldSS && isJust (Map.lookup (AnnKey ss cn) as) then Just $ AnnKey ss cn @@ -150,11 +193,29 @@ | otherwise = Nothing where (con, ~[x, _]) = splitTyConApp (typeOf a) - ss :: GHC.SrcSpan + ss :: AnnSpan ss = gmapQi 0 unsafeCoerce a cn = gmapQi 1 (CN . show . toConstr) a +getAnnSpan :: forall a. Located a -> AnnSpan +getAnnSpan = srcSpanToAnnSpan . getLoc +srcSpanToAnnSpan :: SrcSpan -> AnnSpan +srcSpanToAnnSpan = +#if __GLASGOW_HASKELL__ >= 900 + \case GHC.RealSrcSpan l _ -> l; _ -> badRealSrcSpan +#else + id +#endif + +annSpanToSrcSpan :: AnnSpan -> SrcSpan +annSpanToSrcSpan = +#if __GLASGOW_HASKELL__ >= 900 + flip GHC.RealSrcSpan Nothing +#else + id +#endif + -- | Perform the necessary adjustments to annotations when replacing -- one Located thing with another Located thing. -- @@ -165,7 +226,7 @@ => mod -> Located old -> Located new -> M (Located new) modifyAnnKey m e1 e2 = do as <- gets fst - let parentKey = fromMaybe (mkAnnKey e2) (findParent (getLoc e2) as m) + let parentKey = fromMaybe (mkAnnKey e2) (findParent (getAnnSpan e2) as m) e2 <$ modify ( bimap ( recoverBackquotes e1 e2 @@ -179,7 +240,7 @@ -- -- See tests/examples/Backquotes.hs for an example. recoverBackquotes :: Located old -> Located new -> Anns -> Anns -recoverBackquotes (L old _) (L new _) anns +recoverBackquotes (getAnnSpan -> old) (getAnnSpan -> new) anns | Just annOld <- Map.lookup (AnnKey old (CN "Unqual")) anns , ( (G GHC.AnnBackquote, DP (i, j)) : rest@( (G GHC.AnnVal, _) @@ -210,9 +271,25 @@ setSrcSpanFile :: FastString -> SrcSpan -> SrcSpan setSrcSpanFile file s - | RealSrcLoc start <- srcSpanStart s - , RealSrcLoc end <- srcSpanEnd s + | RealSrcLoc' start <- srcSpanStart s + , RealSrcLoc' end <- srcSpanEnd s = let start' = mkSrcLoc file (srcLocLine start) (srcLocCol start) end' = mkSrcLoc file (srcLocLine end) (srcLocCol end) in mkSrcSpan start' end' setSrcSpanFile _ s = s + +setRealSrcSpanFile :: FastString -> RealSrcSpan -> RealSrcSpan +setRealSrcSpanFile file s = mkRealSrcSpan start' end' + where + start = realSrcSpanStart s + end = realSrcSpanEnd s + start' = mkRealSrcLoc file (srcLocLine start) (srcLocCol start) + end' = mkRealSrcLoc file (srcLocLine end) (srcLocCol end) + +setAnnSpanFile :: FastString -> AnnSpan -> AnnSpan +setAnnSpanFile = +#if __GLASGOW_HASKELL__ >= 900 + setRealSrcSpanFile +#else + setSrcSpanFile +#endif