Skip to content

Commit f6402ca

Browse files
zliu41zliu41
authored
Merge pull request #99 from zliu41/string
Make applyRefactorings take [String] instead of ([Extension], [Extension])
2 parents 4af6ade + ebf2c85 commit f6402ca

File tree

4 files changed

+109
-119
lines changed

4 files changed

+109
-119
lines changed

‎apply-refact.cabal

Lines changed: 0 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -44,9 +44,6 @@ library
4444
, filemanip >= 0.3.6.3 && < 0.4
4545
, unix-compat >= 0.5.2
4646
, directory >= 1.3
47-
if impl(ghc >= 8.8)
48-
build-depends:
49-
ghc-lib-parser-ex >= 8.10.0.16
5047
hs-source-dirs: src
5148
default-language: Haskell2010
5249

@@ -80,9 +77,6 @@ executable refactor
8077
, unix-compat
8178
, filepath
8279
, transformers
83-
if impl(ghc >= 8.8)
84-
build-depends:
85-
ghc-lib-parser-ex >= 8.10.0.16
8680

8781
Test-Suite test
8882
type: exitcode-stdio-1.0
@@ -117,6 +111,3 @@ Test-Suite test
117111
, filepath
118112
, silently
119113
, transformers
120-
if impl(ghc >= 8.8)
121-
build-depends:
122-
ghc-lib-parser-ex >= 8.10.0.16

‎cabal.project

Lines changed: 0 additions & 2 deletions
This file was deleted.

‎src/Refact/Apply.hs

Lines changed: 11 additions & 108 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,3 @@
1-
{-# LANGUAGE CPP #-}
21
{-# LANGUAGE TupleSections #-}
32

43
module Refact.Apply
@@ -7,18 +6,12 @@ module Refact.Apply
76
, parseExtensions
87
) where
98

10-
import Data.List
11-
import GHC.LanguageExtensions.Type (Extension(..))
9+
import Control.Monad (unless)
10+
import Data.List (intercalate)
1211
import Refact.Fixity
1312
import Refact.Internal
1413
import Refact.Types
1514

16-
#if __GLASGOW_HASKELL__ <= 806
17-
import DynFlags (FlagSpec(flagSpecFlag, flagSpecName), xFlags)
18-
#else
19-
import Language.Haskell.GhclibParserEx.GHC.Driver.Session (impliedXFlags, readExtension)
20-
#endif
21-
2215
-- | Apply a set of refactorings as supplied by hlint
2316
applyRefactorings
2417
:: Maybe (Int, Int)
@@ -34,106 +27,16 @@ applyRefactorings
3427
-- prior to it which has an overlapping source span and is not filtered out.
3528
-> FilePath
3629
-- ^ Target file
37-
-> ([Extension], [Extension])
38-
-- ^ Enabled and disabled extensions. These are in addition to the @LANGUAGE@ pragmas
39-
-- in the target file. When they conflict with the @LANGUAGE@ pragmas, pragmas win.
30+
-> [String]
31+
-- ^ GHC extensions, e.g., @LambdaCase@, @NoStarIsType@. The list is processed from left
32+
-- to right. An extension (e.g., @StarIsType@) may be overridden later (e.g., by @NoStarIsType@).
33+
--
34+
-- These are in addition to the @LANGUAGE@ pragmas in the target file. When they conflict
35+
-- with the @LANGUAGE@ pragmas, pragmas win.
4036
-> IO String
4137
applyRefactorings optionsPos inp file exts = do
38+
let (enabled, disabled, invalid) = parseExtensions exts
39+
unless (null invalid) . fail $ "Unsupported extensions: " ++ intercalate ", " invalid
4240
(as, m) <- either (onError "apply") (uncurry applyFixities)
43-
=<< parseModuleWithArgs exts file
41+
=<< parseModuleWithArgs (enabled, disabled) file
4442
apply optionsPos False ((mempty,) <$> inp) file Silent as m
45-
46-
-- | Parse the input into (enabled extensions, disabled extensions, invalid input).
47-
-- Implied extensions are automatically added. For example, @FunctionalDependencies@
48-
-- implies @MultiParamTypeClasses@, and @RebindableSyntax@ implies @NoImplicitPrelude@.
49-
--
50-
-- The input is processed from left to right. An extension (e.g., @StarIsType@)
51-
-- may be overridden later (e.g., by @NoStarIsType@).
52-
--
53-
-- Extensions that appear earlier in the input will appear later in the output.
54-
-- Implied extensions appear in the end. If an extension occurs multiple times in the input,
55-
-- the last one is used.
56-
--
57-
-- >>> parseExtensions ["GADTs", "RebindableSyntax", "StarIsType", "GADTs", "InvalidExtension", "NoStarIsType"]
58-
-- ([GADTs, RebindableSyntax, GADTSyntax, MonoLocalBinds], [StarIsType, ImplicitPrelude], ["InvalidExtension"])
59-
parseExtensions :: [String] -> ([Extension], [Extension], [String])
60-
parseExtensions = addImplied . foldl' f mempty
61-
where
62-
f :: ([Extension], [Extension], [String]) -> String -> ([Extension], [Extension], [String])
63-
f (ys, ns, is) ('N' : 'o' : s) | Just ext <- readExtension s =
64-
(delete ext ys, ext : delete ext ns, is)
65-
f (ys, ns, is) s | Just ext <- readExtension s =
66-
(ext : delete ext ys, delete ext ns, is)
67-
f (ys, ns, is) s = (ys, ns, s : is)
68-
69-
addImplied :: ([Extension], [Extension], [String]) -> ([Extension], [Extension], [String])
70-
addImplied (ys, ns, is) = (ys ++ impliedOn, ns ++ impliedOff, is)
71-
where
72-
impliedOn = [b | ext <- ys, (a, True, b) <- impliedXFlags, a == ext]
73-
impliedOff = [b | ext <- ys, (a, False, b) <- impliedXFlags, a == ext]
74-
75-
#if __GLASGOW_HASKELL__ <= 806
76-
readExtension :: String -> Maybe Extension
77-
readExtension s = flagSpecFlag <$> find ((== s) . flagSpecName) xFlags
78-
79-
-- | Copied from "Language.Haskell.GhclibParserEx.GHC.Driver.Session", in order to
80-
-- support GHC 8.6
81-
impliedXFlags :: [(Extension, Bool, Extension)]
82-
impliedXFlags
83-
-- See Note [Updating flag description in the User's Guide]
84-
= [ (RankNTypes, True, ExplicitForAll)
85-
, (QuantifiedConstraints, True, ExplicitForAll)
86-
, (ScopedTypeVariables, True, ExplicitForAll)
87-
, (LiberalTypeSynonyms, True, ExplicitForAll)
88-
, (ExistentialQuantification, True, ExplicitForAll)
89-
, (FlexibleInstances, True, TypeSynonymInstances)
90-
, (FunctionalDependencies, True, MultiParamTypeClasses)
91-
, (MultiParamTypeClasses, True, ConstrainedClassMethods) -- c.f. #7854
92-
, (TypeFamilyDependencies, True, TypeFamilies)
93-
94-
, (RebindableSyntax, False, ImplicitPrelude) -- NB: turn off!
95-
96-
, (DerivingVia, True, DerivingStrategies)
97-
98-
, (GADTs, True, GADTSyntax)
99-
, (GADTs, True, MonoLocalBinds)
100-
, (TypeFamilies, True, MonoLocalBinds)
101-
102-
, (TypeFamilies, True, KindSignatures) -- Type families use kind signatures
103-
, (PolyKinds, True, KindSignatures) -- Ditto polymorphic kinds
104-
105-
-- TypeInType is now just a synonym for a couple of other extensions.
106-
, (TypeInType, True, DataKinds)
107-
, (TypeInType, True, PolyKinds)
108-
, (TypeInType, True, KindSignatures)
109-
110-
-- AutoDeriveTypeable is not very useful without DeriveDataTypeable
111-
, (AutoDeriveTypeable, True, DeriveDataTypeable)
112-
113-
-- We turn this on so that we can export associated type
114-
-- type synonyms in subordinates (e.g. MyClass(type AssocType))
115-
, (TypeFamilies, True, ExplicitNamespaces)
116-
, (TypeOperators, True, ExplicitNamespaces)
117-
118-
, (ImpredicativeTypes, True, RankNTypes)
119-
120-
-- Record wild-cards implies field disambiguation
121-
-- Otherwise if you write (C {..}) you may well get
122-
-- stuff like " 'a' not in scope ", which is a bit silly
123-
-- if the compiler has just filled in field 'a' of constructor 'C'
124-
, (RecordWildCards, True, DisambiguateRecordFields)
125-
126-
, (ParallelArrays, True, ParallelListComp)
127-
128-
, (JavaScriptFFI, True, InterruptibleFFI)
129-
130-
, (DeriveTraversable, True, DeriveFunctor)
131-
, (DeriveTraversable, True, DeriveFoldable)
132-
133-
-- Duplicate record fields require field disambiguation
134-
, (DuplicateRecordFields, True, DisambiguateRecordFields)
135-
136-
, (TemplateHaskell, True, TemplateHaskellQuotes)
137-
, (Strict, True, StrictData)
138-
]
139-
#endif

‎src/Refact/Internal.hs

Lines changed: 98 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ module Refact.Internal
1414
, runRefactoring
1515
, addExtensionsToFlags
1616
, parseModuleWithArgs
17+
, parseExtensions
1718

1819
-- * Support for runPipe in the main process
1920
, Verbosity(..)
@@ -688,3 +689,100 @@ parseModuleWithArgs (es, ds) fp = ghcWrapper $ do
688689
_ <- GHC.setSessionDynFlags flags
689690
res <- parseModuleApiAnnsWithCppInternal defaultCppOptions flags fp
690691
pure $ postParseTransform res rigidLayout
692+
693+
694+
-- | Parse the input into (enabled extensions, disabled extensions, invalid input).
695+
-- Implied extensions are automatically added. For example, @FunctionalDependencies@
696+
-- implies @MultiParamTypeClasses@, and @RebindableSyntax@ implies @NoImplicitPrelude@.
697+
--
698+
-- The input is processed from left to right. An extension (e.g., @StarIsType@)
699+
-- may be overridden later (e.g., by @NoStarIsType@).
700+
--
701+
-- Extensions that appear earlier in the input will appear later in the output.
702+
-- Implied extensions appear in the end. If an extension occurs multiple times in the input,
703+
-- the last one is used.
704+
--
705+
-- >>> parseExtensions ["GADTs", "RebindableSyntax", "StarIsType", "GADTs", "InvalidExtension", "NoStarIsType"]
706+
-- ([GADTs, RebindableSyntax, GADTSyntax, MonoLocalBinds], [StarIsType, ImplicitPrelude], ["InvalidExtension"])
707+
parseExtensions :: [String] -> ([Extension], [Extension], [String])
708+
parseExtensions = addImplied . foldl' f mempty
709+
where
710+
f :: ([Extension], [Extension], [String]) -> String -> ([Extension], [Extension], [String])
711+
f (ys, ns, is) ('N' : 'o' : s) | Just ext <- readExtension s =
712+
(delete ext ys, ext : delete ext ns, is)
713+
f (ys, ns, is) s | Just ext <- readExtension s =
714+
(ext : delete ext ys, delete ext ns, is)
715+
f (ys, ns, is) s = (ys, ns, s : is)
716+
717+
addImplied :: ([Extension], [Extension], [String]) -> ([Extension], [Extension], [String])
718+
addImplied (ys, ns, is) = (ys ++ impliedOn, ns ++ impliedOff, is)
719+
where
720+
impliedOn = [b | ext <- ys, (a, True, b) <- impliedXFlags, a == ext]
721+
impliedOff = [b | ext <- ys, (a, False, b) <- impliedXFlags, a == ext]
722+
723+
readExtension :: String -> Maybe Extension
724+
readExtension s = flagSpecFlag <$> find ((== s) . flagSpecName) xFlags
725+
726+
-- | Copied from "Language.Haskell.GhclibParserEx.GHC.Driver.Session", in order to
727+
-- support GHC 8.6
728+
impliedXFlags :: [(Extension, Bool, Extension)]
729+
impliedXFlags
730+
-- See Note [Updating flag description in the User's Guide]
731+
= [ (RankNTypes, True, ExplicitForAll)
732+
, (QuantifiedConstraints, True, ExplicitForAll)
733+
, (ScopedTypeVariables, True, ExplicitForAll)
734+
, (LiberalTypeSynonyms, True, ExplicitForAll)
735+
, (ExistentialQuantification, True, ExplicitForAll)
736+
, (FlexibleInstances, True, TypeSynonymInstances)
737+
, (FunctionalDependencies, True, MultiParamTypeClasses)
738+
, (MultiParamTypeClasses, True, ConstrainedClassMethods) -- c.f. #7854
739+
, (TypeFamilyDependencies, True, TypeFamilies)
740+
741+
, (RebindableSyntax, False, ImplicitPrelude) -- NB: turn off!
742+
743+
, (DerivingVia, True, DerivingStrategies)
744+
745+
, (GADTs, True, GADTSyntax)
746+
, (GADTs, True, MonoLocalBinds)
747+
, (TypeFamilies, True, MonoLocalBinds)
748+
749+
, (TypeFamilies, True, KindSignatures) -- Type families use kind signatures
750+
, (PolyKinds, True, KindSignatures) -- Ditto polymorphic kinds
751+
752+
-- TypeInType is now just a synonym for a couple of other extensions.
753+
, (TypeInType, True, DataKinds)
754+
, (TypeInType, True, PolyKinds)
755+
, (TypeInType, True, KindSignatures)
756+
757+
-- AutoDeriveTypeable is not very useful without DeriveDataTypeable
758+
, (AutoDeriveTypeable, True, DeriveDataTypeable)
759+
760+
-- We turn this on so that we can export associated type
761+
-- type synonyms in subordinates (e.g. MyClass(type AssocType))
762+
, (TypeFamilies, True, ExplicitNamespaces)
763+
, (TypeOperators, True, ExplicitNamespaces)
764+
765+
, (ImpredicativeTypes, True, RankNTypes)
766+
767+
-- Record wild-cards implies field disambiguation
768+
-- Otherwise if you write (C {..}) you may well get
769+
-- stuff like " 'a' not in scope ", which is a bit silly
770+
-- if the compiler has just filled in field 'a' of constructor 'C'
771+
, (RecordWildCards, True, DisambiguateRecordFields)
772+
773+
, (ParallelArrays, True, ParallelListComp)
774+
775+
, (JavaScriptFFI, True, InterruptibleFFI)
776+
777+
, (DeriveTraversable, True, DeriveFunctor)
778+
, (DeriveTraversable, True, DeriveFoldable)
779+
780+
-- Duplicate record fields require field disambiguation
781+
, (DuplicateRecordFields, True, DisambiguateRecordFields)
782+
783+
, (TemplateHaskell, True, TemplateHaskellQuotes)
784+
, (Strict, True, StrictData)
785+
#if __GLASGOW_HASKELL__ >= 810
786+
, (StandaloneKindSignatures, False, CUSKs)
787+
#endif
788+
]

0 commit comments

Comments
 (0)